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

[algammal]

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

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

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

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

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

&

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

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

وبعد

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

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

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

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

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

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

 

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

تم تعديل منذ 7 ساعات بواسطه 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