كود لترحيل الى شيتات متعدده

[mk_mk_79]

كود ترحيل مراكز وترحيل كل مركز الى شيت منفصل مع ترحيل الجدول بالكامل 

ترحيل 1 الى شيتات منفصلة.xlsx

[محمد هشام.]

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

تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله 

Public Sub Split_Sheets()
    Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook
    Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String
    Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String
    Dim fileCount As Integer

    folder = "المراكز"
    fullPath = ThisWorkbook.Path & "\" & folder

    If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath
    Set WS = ActiveWorkbook.Worksheets("Sheet1")
    AutoFilterWasOn = WS.AutoFilterMode
    If AutoFilterWasOn Then WS.AutoFilterMode = False
    lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row

    Set tmp = New Collection
    On Error Resume Next
    For Each cell In WS.Range("D3:D" & lastRow)
        If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then
            tmp.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0

    With Application
        .ScreenUpdating = False
        .CopyObjectsWithCells = False
        .Calculation = xlCalculationManual
    End With

    fileCount = 0

    For Each rCrit In tmp
        With WS.Range("B2:H2")
            .AutoFilter Field:=3, Criteria1:=rCrit
        End With

        On Error Resume Next
        Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not Rng Is Nothing Then
            Set newWb = Workbooks.Add(xlWBATWorksheet)
            Set f = newWb.Worksheets(1)

            s = rCrit
            Chars = ":\/?*[]"
            For i = 1 To Len(Chars)
                s = Replace(s, Mid(Chars, i, 1), "_")
            Next i
            If Len(s) > 31 Then s = Left(s, 31)

            f.Name = s
            f.DisplayRightToLeft = True
            Rng.Copy f.Range("B2")

            For col = 2 To 8
                If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then
                    f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth
                End If
            Next col

            f.Rows(1).RowHeight = WS.Rows(1).RowHeight
            Application.DisplayAlerts = False
            newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook
            Application.DisplayAlerts = True

            newWb.Close False

            fileCount = fileCount + 1
        End If
    Next rCrit

    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If

    With Application
        .ScreenUpdating = True
        .CopyObjectsWithCells = True
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation
End Sub

 لقد لاحظت وجود أسماء رقمية في عمود المركز

    ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها  عدل هدا السطر
             'من 
         If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then
         'الى
         If Len(cell.Value) > 0 Then

 

ترحيل 1 الى شيتات منفصلة v1.xlsb

[mk_mk_79]

الاستاذ / محمد هشام 

بارك الله فيك . وزادك الله علما حتى تنفع به الاخرين . هو المطلوب بالضبط . وانا بشكر حضرتك ومهما قولت من كلمات شكر مش حتوفيك حقك . وشاكر تعبك معايا . ومعلش فى تاخير الرد 

[elmansyeswa]

بارك الله فيك وجعله بميزان حسناتك