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

[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]

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

[Abaas]

السلام عليكم ..كل الشكر للاخ محمد هشام .. 

هل من الممكن ان يكون ترحيل المراكز في شيت واحد ضمن المصنف بحيث تكون الجداول الواحد اسفل التالي ويكون بين كل جدول صف فارغ لغرص فصل المراكز ويكون اعلى كل جدول يتوسط اسم المركز وكذلك يكول كل جدول برقم متسلسل من ١ الى كذا من الداتا الموجوة في كل صف .. شاكرين مجهودكم

تم تعديل مارس 24 بواسطه Abaas

[محمد هشام.]

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

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

ادا كان هناك تغيير في نطاق البيانات يرجى دكر النطاق المطلوب او إرفاق عينة لشكل البيانات لديك 

[Abaas]

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

تم تعديل مارس 24 بواسطه Abaas