تعديل على كود يقوم بفتح عدة شيتات

[محمد عبد الناصر]

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

في ها الكود يقوم بفتح عدة شيتات على حسب الاسم المكتوب في العمود C في كل خليه به

المطلوب ان يقوم بنسخ البيانات وترحيلها الى الشيت المخصص لها حسب المكتوب في العمود C فمثلا في الخلية C4 مكتوب كنوز فيقوم بنسخ الصف الى شيت كنوز الخليه C5 مكتوب ادعية يقوم بنسخ الصف الى شيت ادعية 
ومطلوب ان يجعل العمود B في كل الشيتات size 70 

ويقوم ايضا بنسخ الصف 5 ويضعه في كل الشيتات في الصف رقم 5 

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

Sub CreateSheets()
     
    Dim lra As Integer
    Dim My_Rg As Range
    Dim ListSh As Range
     lra = Cells(Rows.Count, "c").End(xlUp).Row

     Set ListSh = Worksheets("Sheet1").Range("c6:h" & lra)

     
    On Error Resume Next
    For Each My_Rg In ListSh
        If Len(Trim(My_Rg.Value)) > 0 Then
            If Len(Worksheets(My_Rg.Value).Name) = 0 Then
                Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = My_Rg.Value
            End If
        End If
      Worksheets("Sheet1").Select
    Next My_Rg
    
Applications.Calculations = xlCalculationManual
    
     End Sub

 

اسلاميات.xlsm

[محمد هشام.]

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

Sub CreateSheets()
    Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1")
    Dim MyRng As Range, RngCopy As Range, Sh As Collection
    Dim cell As Range, DerLig  As Long
    Dim wsDest As Variant, s As String
    
    
    Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row)
    Set Sh = New Collection

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

        For Each WS In Sheets
           If WS.Name <> mydata.Name Then WS.Delete
        Next
        On Error Resume Next
        For Each cell In MyRng.Cells
            Sh.Add cell.Value, CStr(cell.Value)
        
    Next cell
    On Error GoTo 0
    For Each wsDest In Sh
        s = wsDest
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest
        ActiveSheet.DisplayRightToLeft = True

With mydata

DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row
        .Range("A5").AutoFilter field:=3, Criteria1:=wsDest
Set RngCopy = .Range("A5:C" & DerLig)
         RngCopy.Copy Sheets(s).Range("A5")
        .Select
        .[A5].AutoFilter

        End With
        
    Next wsDest
    
For Each wscopy In ThisWorkbook.Worksheets
        If wscopy.Name <> mydata.Name Then

    For i = 1 To 3
    wscopy.Cells.EntireRow.AutoFit
    wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth
    wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight
    wscopy.Columns("B:B").ColumnWidth = 70
    wscopy.Activate
    With ActiveWindow
                .SplitRow = 5
                .SplitColumn = 0
                .FreezePanes = True
            End With
                Next
            End If
        Next wscopy
mydata.Activate

With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub

 

اسلاميات 2.xlsm

[محمد عبد الناصر]

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

ولكن لماذا يقوم بمسح اي شيت اخر موجود فمثلا يقوم بمسح sheet2 وهو غير مكتوب في العمود C لا اريد ان يتم مسح اي شيت اخر عند تفعيل الكود

تم تعديل أكتوبر 22, 2023 بواسطه محمد عبد الناصر

[محمد هشام.]

يمكنك استثناء اوراق العمل الاخرى داخل الكود بالطريقة التالية 

Sub CreateSheets()
    Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1")
    Dim MyRng As Range, RngCopy As Range, Sh As Collection
    Dim cell As Range, DerLig  As Long, ws As Worksheet
    Dim wsDest As Variant, s As String, SheetName As String
    
    
    Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row)
    Set Sh = New Collection

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

'*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا**************

SheetName = "Sheet1,Sheet2"

'***********************************************************************************

Application.ScreenUpdating = False

For Each ws In Worksheets
  If InStr(1, SheetName, ws.Name) = 0 Then
    Réf = Application.Match(ws.Name, arr, 0)
    If IsError(Réf) Then
      ws.Delete
    End If
  End If
Next ws
        On Error Resume Next
        For Each cell In MyRng.Cells
            Sh.Add cell.Value, CStr(cell.Value)
        
    Next cell
    On Error GoTo 0
    For Each wsDest In Sh
        s = wsDest
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest
        ActiveSheet.DisplayRightToLeft = True

With mydata

DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row
        .Range("A5").AutoFilter field:=3, Criteria1:=wsDest
Set RngCopy = .Range("A5:C" & DerLig)
         RngCopy.Copy Sheets(s).Range("A5")
        .Select
        .[A5].AutoFilter

        End With
        
    Next wsDest
    
For Each wscopy In Worksheets
  If InStr(1, SheetName, wscopy.Name) = 0 Then
    Réf = Application.Match(wscopy.Name, arr, 0)
    If IsError(Réf) Then
    For i = 1 To 3
    wscopy.Cells.EntireRow.AutoFit
    wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth
    wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight
    wscopy.Columns("B:B").ColumnWidth = 70
    wscopy.Activate
    With ActiveWindow
                .SplitRow = 5
                .SplitColumn = 0
                .FreezePanes = True
            End With
                Next
            End If
            End If
        Next wscopy
mydata.Activate

With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub

 

 

 

اسلاميات 3.xlsm

تم تعديل أكتوبر 22, 2023 بواسطه محمد هشام.

[محمد عبد الناصر]

ماشاء الله هو المطلوب تمام جزاك الله كل خير