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

[algammal]

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

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

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

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

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

&

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

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

وبعد

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

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

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

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

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

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

 

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

تم تعديل الجمعة at 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) شيت (معاشات) فقد تم حله بفضل الله.

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

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

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

  

 

[عبدالله بشير عبدالله]

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

أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh
شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه.
أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا.

كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal.

تحياتي واحترامي لك أخي العزيز،

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

مع خالص التحية والتقدير لكما ولكل منابعى المنتدى،

الكود

Sub ترحيل_البيانات()
    Dim wsMain As Worksheet, wsNew As Worksheet
    Dim dict As Object, dataArray As Variant
    Dim i As Long, lastRow As Long, targetRow As Long
    Dim startTime As Double: startTime = Timer
    Dim sheetName As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..."
    End With
    
    On Error GoTo ErrorHandler
    
    Set wsMain = ThisWorkbook.Sheets("معاشات")
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    If lastRow < 5 Then Exit Sub
    dataArray = wsMain.Range("A5:M" & lastRow).Value
    
    For i = 1 To UBound(dataArray, 1)
        sheetName = Trim(dataArray(i, 5))
        If sheetName <> "" Then dict(sheetName) = Empty
    Next i
    
    Application.DisplayAlerts = False
    For Each wsNew In ThisWorkbook.Worksheets
        If Not wsNew Is wsMain Then
            If dict.exists(wsNew.Name) Then wsNew.Delete
        End If
    Next wsNew
    Application.DisplayAlerts = True
    
    Dim key As Variant, rowIndex As Long
    For Each key In dict.keys
        Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsNew.Name = key
        wsNew.DisplayRightToLeft = True
        
        wsMain.Range("A1:M4").Copy
        wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        
        wsMain.Rows("3:4").Copy
        wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        
        targetRow = 5
        For rowIndex = 1 To UBound(dataArray, 1)
            If Trim(dataArray(rowIndex, 5)) = key Then
                wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow)
                targetRow = targetRow + 1
            End If
        Next rowIndex
        
        For i = 1 To wsMain.UsedRange.Rows.Count
            If i <= wsNew.UsedRange.Rows.Count Then
                wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight
            End If
        Next i
        
        For i = 1 To 13
            wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth
        Next i
    Next key
    
    wsMain.Activate
    
CleanUp:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .StatusBar = False
    End With
    
   ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

 

 الملف

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

 

 

[Foksh]

4 ساعات مضت, algammal said:

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

بداية ، كل العذر منك ، فقد اختلطت علي الأمور قليلاً بين هنا وهناك ، والحق أحق أنني قد تسرعت دون تركيز مني .

 

20 دقائق مضت, عبدالله بشير عبدالله said:

أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh
شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه.
أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا.

أهلا أستاذنا الفاضل @عبدالله بشير عبدالله ، وقد تشرفت بالتعرف على نخبة من عمالقة الإكسل وأنت أحدها طبعاً ( ولا غنى بقية الأخوة والأساتذة والمعلمين ) ، وتطرقي الى اكسل في الفترة الأخيرة لهو نابع من فقري الى الممارسة في برمجة اكسل والتعمق فيه بشكل قوي ، فمعلوماتي وخبرتي فيه ليست بحجم خبرتكم ومعلوماتكم هنا في قسمكم أخي الفاضل .

وطبعاً لن أزايد على كود الأستاذ @عبدالله بشير عبدالله ، لأنه احترافي بشكل فعال أكثر من فكرتي كنت سأطرحها ، حيث انه يستخدم مصفوفة dataArray لمعالجة البيانات في الذاكرة ( أسرع بكثير من فكرتي التي خطرت لي ) ، والعديد من الميزات في اقتراحه أفضل بكثير .

ويسعدني المتابعة معكم والإستفادة من خبرة الأساتذة هنا 

تم تعديل منذ 19 ساعات بواسطه Foksh
تنسيق

[محمد هشام.]

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

أستاذنا الفاضل @Foksh

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

كذلك أود أن أشكر الأخ العزيز @algammal  على إبداعه في تقديم طلبه بكل أدب وتقدير مشيرا إلى الجهد الكبير الذي بذله الأستاذ عبدالله في تلبية طلبه هذه اللفتة تعكس الروح الطيبة بين أعضاء المنتدى وتشجع على تبادل الخبرات بكل تقدير واحترام وهو أمر نفتقده أحيانا في بعض الحالات

كما لا يفوتني أن أوجه التحية والتقدير للأستاذ الفاضل @عبدالله بشير عبدالله على مشاركته القيمة وجهوده المستمرة في دعم ومساعدة أعضاء المنتدى

اسمحوا لي أن أساهم بدوري في إثراء هذا الموضوع من خلال هذا الكود المتواضع رغم أن الحلول المطروحة هنا رائعة بالفعل إلا أنني حاولت التركيز على تحسين الأداء الزمني للكود ليكون أسرع في بعض الحالات خاصة في التعامل مع البيانات الكبيرة إضافة إلى ذلك قمت بتعديل بعض النقاط لتحسين تجربة المستخدم مثل تسريع عمليات النسخ والتنسيق وتقليل التكرار في العمليات مما يساعد في تقليل الوقت المستغرق لتنفيذ الكود

آمل أن تساهم هذه الإضافة في تحسين تجربتنا المشتركة في استخدام إكسل بشكل أكثر كفاءة بالطبع يسرني أن أسمع آراءكم وتعليقاتكم حول أي تحسينات إضافية يمكن أن تفيد الجميع

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

Sub TransferData()
    Const début As Long = 5: Const Height As Double = 20.25
    Const départ As String = "A": Const Fin As String = "M"
    Const harder As String = "A3:M4"
    
    Dim CrWS As Worksheet, tmp As Worksheet, dest As Object, OnRng As Variant
    Dim i As Long, lastRow As Long, tbl As String, f As Variant, k As Variant
    Dim Irow As Long, a() As Variant, n As Long, lr As Long

    On Error GoTo OnError
    Set CrWS = Sheets("معاشات"): Set dest = CreateObject("Scripting.Dictionary")

    lastRow = CrWS.Cells(CrWS.Rows.Count, départ).End(xlUp).Row
    If lastRow < début Then Exit Sub
    SetApp False
    OnRng = CrWS.Range(départ & début & ":" & Fin & lastRow).Value

    For i = 1 To UBound(OnRng, 1)
        tbl = Replace(Trim(OnRng(i, 5)), "/", "_"): tbl = Replace(tbl, "\", "_")
        If Len(tbl) > 0 Then dest(tbl) = Empty
    Next i

    Application.DisplayAlerts = False
    For Each tmp In ThisWorkbook.Worksheets
        If Not tmp Is CrWS Then: If dest.exists(tmp.Name) Then tmp.Delete
    Next tmp
    Application.DisplayAlerts = True

    For Each f In dest.keys
        Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        tmp.Name = f: tmp.DisplayRightToLeft = True

        CrWS.Range(harder).Copy
        tmp.[A3].PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False

        ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2))
        n = 0
        For Irow = 1 To UBound(OnRng, 1)
            If Trim(OnRng(Irow, 5)) = f Then
                n = n + 1
                For i = 1 To UBound(OnRng, 2)
                    a(n, i) = OnRng(Irow, i)
                Next i
            End If
        Next Irow

        If n > 0 Then
            tmp.[A5].Resize(n, UBound(OnRng, 2)).Value = a
            CrWS.Range("A5:M" & n + 4).Copy
            tmp.[A5].PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End If

        CrWS.Columns("A:M").Copy
        tmp.Columns("A:M").PasteSpecial Paste:=xlPasteColumnWidths
        Application.CutCopyMode = False
        
        lr = tmp.Cells(tmp.Rows.Count, départ).End(xlUp).Row
        For i = 1 To lr
            tmp.Rows(i).RowHeight = Height
        Next i
        
        k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & _
                        lr & ", $D$3)", "=COUNTIF($F$5:$F$" & lr & ", $G$3)")
        tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2)
        tmp.Range("A5:A" & lr).Formula = "=IF(B5<>"""",SUBTOTAL(3,$B$5:B5),"""")"
        tmp.[A4].Select

    Next f

    On Error Resume Next
    CrWS.Range("A5:M" & lastRow).FormatConditions.Copy tmp.Range("A5:M" & n + 4)
    On Error GoTo OnError

    CrWS.Activate

CleanUp:
    SetApp True
    MsgBox "تم ترحيل البيانات بنجاح", vbInformation
    Exit Sub
OnError:
    Resume CleanUp
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable
        .EnableEvents = enable
        .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

 

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

[Foksh]

8 ساعات مضت, محمد هشام. said:

أستاذنا الفاضل @Foksh

 

بارك الله بكم جميعاً أخي الأستاذ @محمد هشام. ، وأثابكم الله على ما قدمتم ..

واسمح لي بسؤال متفرع فيما يخص الكود الذي طرحته ..

• هل لك أن تشرح لي حاجتنا لـ (COUNTIF و SUBTOTAL) ؟🤗؟ ( من باب كسب المعلومة )
• وهل اعتمدت فعلاً على مصفوفات فرعية ؟؟

   (ReDim a()

 

 

ومن باب المشاركة وبما أنني قد أخطأت في ماركتي الأولى سابقاً 😅 ، سأقدم فكرتي والتي لا اعتقد انها بكفاءة أفكاركم أهل الديار 🤗 .

Sub CopyDataToWorksheets()
    Dim wsMain As Worksheet, wsNew As Worksheet
    Dim dict As Object, dataArray As Variant, formatsArray As Variant
    Dim i As Long, lastRow As Long, targetRow As Long
    Dim sheetName As String, startTime As Double: startTime = Timer
    Const ROW_HEIGHT As Double = 20.25
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات"
    End With
    
    On Error GoTo ErrorHandler
    
    Set wsMain = ThisWorkbook.Sheets("معاشات")
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    If lastRow < 5 Then GoTo CleanUp
    
    dataArray = wsMain.Range("A5:M" & lastRow).Value
    formatsArray = wsMain.Range("A1:M" & lastRow).FormatConditions
    
    For i = 1 To UBound(dataArray, 1)
        sheetName = CleanSheetName(Trim(dataArray(i, 5)))
        If sheetName <> "" Then dict(sheetName) = Empty
    Next i
    
    Application.DisplayAlerts = False
    For Each wsNew In ThisWorkbook.Worksheets
        If Not wsNew Is wsMain Then
            If dict.exists(wsNew.Name) Then wsNew.Delete
        End If
    Next wsNew
    Application.DisplayAlerts = True
    
    For Each sheetName In dict.keys
        Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsNew.Name = sheetName
        wsNew.DisplayRightToLeft = True
        
        wsMain.Range("A1:M4").Copy
        wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        
        targetRow = 5
        For i = 1 To UBound(dataArray, 1)
            If CleanSheetName(Trim(dataArray(i, 5))) = sheetName Then
                wsNew.Range("A" & targetRow & ":M" & targetRow).Value = Application.Index(dataArray, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13))
                targetRow = targetRow + 1
            End If
        Next i
        
        If Not IsEmpty(formatsArray) Then
            On Error Resume Next
            wsMain.Range("A5:M" & lastRow).FormatConditions.Copy wsNew.Range("A5:M" & targetRow - 1)
            On Error GoTo 0
        End If
        
        With wsNew
            .Rows.RowHeight = ROW_HEIGHT
            
            For i = 1 To 13
                .Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth
            Next i
            
            .Range("E3").Font.Name = "Arial"
        End With
    Next sheetName
    
    wsMain.Range("E3").Font.Name = "Arial"
    wsMain.Activate
    
CleanUp:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .StatusBar = False
    End With
    
    Debug.Print "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية"
    Exit Sub
    
ErrorHandler:
    MsgBox "حدث خطأ في السطر " & Erl & ": " & Err.Description, vbCritical + vbMsgBoxRight,""
    Resume CleanUp
End Sub


Function CleanSheetName(sName As String) As String
    Dim illegalChars As Variant, char As Variant
    illegalChars = Array("\", "/", ":", "?", "*", "[", "]")
    
    CleanSheetName = sName
    For Each char In illegalChars
        CleanSheetName = Replace(CleanSheetName, char, "_")
    Next char
    
    If Len(CleanSheetName) > 31 Then
        CleanSheetName = Left(CleanSheetName, 31)
    End If
End Function

 

تم تعديل منذ 3 ساعات بواسطه Foksh
تنسيق المشاركة