ترحيل البيانات من شيت إلى عدة شيتات مستقلة

[algammal]

السادة خبراء أوفيسنا (اكسيل) الكرام

(السلام عليكم ورحمة الله وبركاته)

بداية أود أن أنوه إلى أن الملف المرفق جهد خالص للأستاذ الفاضل / عبد الله بشير عبد الله

في موضوع سابق بعنوان

(ترحيل بيانات موظف محال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات)

&

(تعديل كود ترحيل بيانات موظف محال للمعاش)

له مني كل الشكر والتقدير والاحترام

وبعد

·شاهدت أحد فيديوهات اليوتيوب وقمت – وهذه أول مرة – بتطبيق ما فيه بما يتناسب مع ما أريده؛ وذلك بإضافة الكود المرفق في (شيت معاشات) وعن طريق (زر ترحيل البيانات) في الشيت نفسه يقوم بترحيل البيانات الموجودة في العمود (E) وفقا للمهن المدونة فيه إلى شيتات مستقلة يحمل كل شيت منها نفس اسم المهنة: (طبيب – مهندس – ضابط – محامي – عامل)؛ وهكذا الحال لو تم إضافة مهنة أخرى أو تعديل في أي بيان يتم التعديل والتحديث بطريقة أوتوماتيكية في الشيتات الناشئة.

·ولكن لاحظت أن الخلايا (J3:B3) لا يتم إدراجها في الشيتات الناشئة فقمت بإدراجها يدويا عن طريق النسخ واللصق؛ ولكن عند الضغط على زر ترحيل البيانات مرة أخرى تختفي؛ وأريدها ثابتة لا تتاثر بشيء.

·وكذلك أريد الاحتفاظ بعرض الأعمدة من B:A في كل الشيتات الناتجة مطابقة تماما لمثيلتها في شيت (معاشات)؛ حيث لاحظت أن العرض يتغير لبعض الأعمدة كما هو موضح في الملف المرفق؛ علما أن عرض الأعمدة من M:C مضبوطة.

·مع ثبات الارتفاع (20.25) في الشيت بأكمله لكل الشيتات الناتجة (طبيب – مهندس – ضابط – محامي – عامل) أو الشيتات التي ممكن أن تنشأ لاحقا نتيجة إضافة مهنة أخرى في العمود (E).

·أود ان يكون الخط (Arial) ثابتا في الخلية (E3) من (شيت معاشات)؛ بدلا من (PT Bold Heading)؛ حيث أنه كلما تم ضبطه يعود ويتغير لما كان عليه بعد الضغط على زر (ترحيل المحالين على المعاش) في شيت (DATA).

ولكم مني جميعا خالص الشكر والتقدير والاحترام؛ وجزاكم الله عنا خير الجزاء.

 

ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb

تم تعديل بالامس في 17:47 بواسطه algammal

[Foksh]

وعليكم السلام ورحمة الله وبركاته ،،

جرب أخي هذا التعديل !!

Sub ترحيل_المعاش_ق()
    Dim wsSource As Worksheet, wsTarget As Worksheet, wsNew As Worksheet
    Dim sourceData As Variant, outputData() As Variant
    Dim i As Long, j As Long, lastRowSource As Long, lastRowTarget As Long
    Dim rowsToDelete As Range, delCount As Long
    Dim totalCols As Long: totalCols = 13
    Dim t As Double: t = Timer
    Dim professions As Object, profession As Variant
    Dim colWidths() As Double
    Dim lastRowAfterInsert As Long
    
    ' تخزين أبعاد الأعمدة من ورقة معاشات
    Set wsTarget = ThisWorkbook.Sheets("معاشات")
    ReDim colWidths(1 To totalCols)
    For i = 1 To totalCols
        colWidths(i) = wsTarget.Columns(i).ColumnWidth
    Next i
    
    Set wsSource = ThisWorkbook.Sheets("DATA")
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .StatusBar = "جاري معالجة البيانات..."
    End With
    
    ' تثبيت الخط في الخلية E3
    With wsTarget.Range("E3")
        .Font.Name = "Arial"
        .Font.Bold = True
    End With
    
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "M").End(xlUp).Row
    If lastRowSource < 5 Then GoTo CleanUp
    
    sourceData = wsSource.Range("A5:M" & lastRowSource).Value
    
    ' إنشاء قاموس للمهن
    Set professions = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(sourceData, 1)
        If LCase(Trim(sourceData(i, 13))) = "معاش" Then
            profession = Trim(sourceData(i, 5))
            If Not professions.Exists(profession) Then
                professions.Add profession, Nothing
            End If
        End If
    Next i
    
    ' معالجة كل مهنة
    For Each profession In professions.Keys
        ' إنشاء أو تحديد الورقة الخاصة بالمهنة
        On Error Resume Next
        Set wsNew = ThisWorkbook.Sheets(profession)
        On Error GoTo 0
        
        If wsNew Is Nothing Then
            Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsNew.Name = profession
        Else
            ' حذف البيانات القديمة مع الحفاظ على التنسيق
            wsNew.Cells.ClearContents
        End If
        
        ' نسخ الترويسة من ورقة معاشات
        wsTarget.Range("B3:J3").Copy
        wsNew.Range("B3").PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        
        ' نسخ البيانات الخاصة بالمهنة الحالية
        delCount = 0
        ReDim outputData(1 To UBound(sourceData, 1), 1 To totalCols)
        
        For i = 1 To UBound(sourceData, 1)
            If LCase(Trim(sourceData(i, 13))) = "معاش" And Trim(sourceData(i, 5)) = profession Then
                delCount = delCount + 1
                For j = 1 To totalCols
                    If (j = 9 Or j = 12) And IsDate(sourceData(i, j)) Then
                        outputData(delCount, j) = Format(sourceData(i, j), "yyyy/mm/dd")
                    Else
                        outputData(delCount, j) = sourceData(i, j)
                    End If
                Next j
            End If
        Next i
        
        If delCount > 0 Then
            lastRowTarget = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row
            If lastRowTarget < 5 Then lastRowTarget = 4
            
            Set targetRange = wsNew.Range("A" & lastRowTarget + 1).Resize(delCount, totalCols)
            targetRange.Value = Application.Index(outputData, Evaluate("ROW(1:" & delCount & ")"), Evaluate("COLUMN(A:M)"))
            
            ' تطبيق التنسيق
            With targetRange
                .Borders.LineStyle = xlContinuous
                .Borders.Weight = xlMedium
                .Borders.ColorIndex = xlAutomatic
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .ShrinkToFit = True
                With .Font
                    .Name = "Arial"
                    .FontStyle = "غامق"
                    .Size = 12
                End With
            End With
            
            With wsNew.Range("B5:B10000")
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlCenter
            End With
            
            ' ضبط ارتفاع الصفوف
            wsNew.Rows("5:" & (lastRowTarget + delCount)).RowHeight = 20.25
            
            ' ضبط عرض الأعمدة
            For i = 1 To totalCols
                wsNew.Columns(i).ColumnWidth = colWidths(i)
            Next i
            
            ' تطبيق التنسيق الشرطي
            With wsNew.Range("A5:M" & (lastRowTarget + delCount))
                .FormatConditions.Delete
                .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش"""
                With .FormatConditions(1)
                    .Font.Bold = True
                    .Font.Color = -16776961
                    .Interior.Color = 16764159
                    .StopIfTrue = False
                End With
            End With
        End If
        
        Set wsNew = Nothing
    Next profession
    
    ' حذف الصفوف من ورقة DATA
    Set rowsToDelete = Nothing
    For i = 1 To UBound(sourceData, 1)
        If LCase(Trim(sourceData(i, 13))) = "معاش" Then
            If rowsToDelete Is Nothing Then
                Set rowsToDelete = wsSource.Rows(i + 4)
            Else
                Set rowsToDelete = Union(rowsToDelete, wsSource.Rows(i + 4))
            End If
        End If
    Next i
    
    If Not rowsToDelete Is Nothing Then
        rowsToDelete.Delete Shift:=xlUp
    End If
    
    ' تحديث ورقة معاشات
    With wsTarget
        lastRowAfterInsert = .Cells(.Rows.Count, "B").End(xlUp).Row
        
        If lastRowAfterInsert >= 5 Then
            With .Range("A4:M" & lastRowAfterInsert)
                .Sort Key1:=.Columns(12), Order1:=xlAscending, _
                      Header:=xlYes, Orientation:=xlTopToBottom
            End With
            
            With .Range("A5:M" & lastRowAfterInsert)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .ShrinkToFit = True
                With .Font
                    .Name = "Arial"
                    .FontStyle = "غامق"
                    .Size = 12
                End With
            End With
            
            With .Range("B5:B10000")
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlCenter
            End With
            
            .Rows("5:" & lastRowAfterInsert).RowHeight = 20.25
            
            With .Range("A5:M" & lastRowAfterInsert)
                .FormatConditions.Delete
                .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش"""
                With .FormatConditions(1)
                    .Font.Bold = True
                    .Font.Color = -16776961
                    .Interior.Color = 16764159
                    .StopIfTrue = False
                End With
            End With
        End If
    End With
    
    ' تحديث الصيغ
    With wsTarget
        .Columns("D").NumberFormat = "0"
        .Range("A5").FormulaR1C1 = "=IF(RC[1]<>"""",SUBTOTAL(3,R5C2:RC[1]),"""")"
        .Range("A6:A10000").FormulaR1C1 = .Range("A5").FormulaR1C1
    End With
    
    عد_الذكور_والإناث_والمعاشات
    
CleanUp:
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .StatusBar = False
    End With
    
    Debug.Print "تم الانتهاء في: " & Round(Timer - t, 2) & " ثانية"
End Sub

 

[algammal]

أخي الكريم / Foksh

السلام عليكم ورحمة الله وبركاته 

بداية أشكر لكم سرعة الرد؛ وأتمنى أن تدلني على الطريقة التي قمت فيها بإرسال الكود على النحو المبين أعلاه

حتى أستطيع أن أتواصل معكم بنفس الطريقة وكتابة الكود الذي أقصده

حتى نتوصل لتفاهم مشترك؛ وتقصير المسافة نحو الوصول للمطلوب

وجزاكم الله خيرا؛ وتقبل خالص تحياتي وتقديري 

[Foksh]

اهلا اخي الكريم 🤗 

الأمر بسيط بإذن الله تعالى ، في المكان الذي تكتب فيه رسالتك او موضوعك أو ردك ، يوجد زر <> هذا الزر وظيفته لكتابة الأكواد التي تود مشاركتها معنا ، جربه وستجد الموضوع بتنسيق ونمط جميلين في ردودك لاحقاً.

[algammal]

أخي الكريم / Foksh

السلام عليكم ورحمة الله وبركاته

جزاكم الله خيرا على المعلومة الجديدة بالنسبة لي

أما بخصوص الكود التالي - والذي لكم الفضل في أن يظهر بهذا الشكل - والذي أعنيه فهو موجود في ورقة2 شيت ( معاشات) وبدايته هي:

Sub CopyDataToWorksheets()
    Dim wsData As Worksheet
    Dim wsNew As Worksheet
    Dim cell As Range
    Dim lastRow As Long
    Dim i As Long
    Dim sheetNames As Object
    Set sheetNames = CreateObject("Scripting.Dictionary")
    
    ' تعيين الورقة التي تحتوي على البيانات (اسم الورقة هو "معاشات")
    Set wsData = ThisWorkbook.Sheets("معاشات")
    
    Application.ScreenUpdating = False ' تعطيل تحديث الشاشة لتسريع الأداء
    
    ' حساب آخر صف غير فارغ في العمود E
    lastRow = wsData.Cells(wsData.Rows.Count, "E").End(xlUp).Row
    
    ' تحويل البيانات في العمود E إلى أسماء الأوراق العمل ونسخ الصفوف المناسبة
    For Each cell In wsData.Range("E5:E" & lastRow)
        ' التحقق من صحة الأحرف في اسم الورقة العمل
        Dim sheetName As Variant
        sheetName = Trim(CStr(cell.Value))
        
        ' التحقق من صحة اسم الورقة العمل المحدثة
        If sheetName <> "" Then
            ' إضافة اسم الورقة الجديدة إلى القاموس (دون تكرار)
            If Not sheetNames.exists(sheetName) Then
                sheetNames(sheetName) = 1
            End If
        End If
    Next cell
    
    ' حذف الأوراق القديمة المطابقة وإنشاء أوراق جديدة
    For Each wsNew In ThisWorkbook.Sheets
        If Not wsNew Is wsData Then
            If sheetNames.exists(wsNew.Name) Then
                ' حذف الأوراق القديمة
                Application.DisplayAlerts = False
                wsNew.Delete
                Application.DisplayAlerts = True
            End If
        End If
    Next wsNew
    
    ' إنشاء الأوراق الجديدة ونسخ البيانات المطابقة
    For Each sheetName In sheetNames.keys
        If Not SheetExists(CStr(sheetName)) Then
            Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsNew.Name = CStr(sheetName)
            wsData.Rows(4).Copy Destination:=wsNew.Rows(4)
            
            i = 5 ' تبدأ من الصف الثاني
            Do Until IsEmpty(wsData.Cells(i, "E"))
                If wsData.Cells(i, "E").Value = CStr(sheetName) Then
                    wsData.Rows(i).Copy Destination:=wsNew.Rows(wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row + 1)
                End If
                i = i + 1
            Loop
            
            ' تعديل عرض الأعمدة في الورقة الجديدة وفقًا للعرض في الورقة الأصلية
            wsData.Columns.AutoFit
            wsNew.Columns.AutoFit
        End If
    Next sheetName
    
    Application.ScreenUpdating = True ' تمكين تحديث الشاشة مرة أخرى
End Sub

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetName Then
            SheetExists = True
            Exit Function
        End If
    Next ws
    SheetExists = False
End Function

فقط أود أن ألفت الانتباه إلى أن الكود الموجود في (Module1) يعمل بكفاءة عالية ولا أريد التعديل عليه حيث أنه مرتبط بزر (ترحيل المحالين على المعاش) في شيت (DATA) إلى شيت (معاشات)؛ وما أريده أخي الكريم هو الكود المذكور عاليه والمرتبط بزر (ترحيل البيانات) الموجود في شيت (معاشات) مع الشيتات الناتجة عنه وهي: (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل)؛ ما أريده ألخصه فيما يلي:

1=  أريد ظهور الخلايا (J3:B3) بنفس تنسيقها في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) وأن تظل ثابته لا تتأثر بترحيل البيانات في المرات القادمة حي أنها تختفي كلما قمت بترحيل البيانات.

2= أريد ارتفاع الصف (20.25) في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل) بأكملها من أول صف لآخر صف.   

3= أريد عرض الأعمدة من (B:A) فقط في شيتات (طبيب؛ مهندس؛ ضابط؛ محامي؛ عامل)  مطابقة لعرض الأعمدة المذكورة في شيت (معاشات)؛ حيث أن عرض الأعمدة من (M:C) مضبوطة ولا تحتاج تعديل.

ملحوظة: أما بخصوص الخط في الخلية (E3) شيت (معاشات) فقد تم حله بفضل الله.

هذا والله الموفق والمستعان

وجزاكم الله خير الجزاء؛ وأسعدكم في الدارين: الدنيا والاخرة

وتقبلوا خالص احترامي وتقديري