محمد عبد الناصر قام بنشر أكتوبر 22, 2023 مشاركة قام بنشر أكتوبر 22, 2023 السلام عليكم ورحمة الله وبركاته,,, في ها الكود يقوم بفتح عدة شيتات على حسب الاسم المكتوب في العمود 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 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أكتوبر 22, 2023 مشاركة قام بنشر أكتوبر 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 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 3 رابط هذا التعليق شارك More sharing options...
محمد عبد الناصر قام بنشر أكتوبر 22, 2023 الكاتب مشاركة قام بنشر أكتوبر 22, 2023 (معدل) ماشاء الله استاذ محمد هاشم بارك الله فيك وفي علمك وجعله الله في ميزان حسناتك ولكن لماذا يقوم بمسح اي شيت اخر موجود فمثلا يقوم بمسح sheet2 وهو غير مكتوب في العمود C لا اريد ان يتم مسح اي شيت اخر عند تفعيل الكود تم تعديل أكتوبر 22, 2023 بواسطه محمد عبد الناصر رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر أكتوبر 22, 2023 أفضل إجابة مشاركة قام بنشر أكتوبر 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 بواسطه محمد هشام. 3 رابط هذا التعليق شارك More sharing options...
محمد عبد الناصر قام بنشر أكتوبر 22, 2023 الكاتب مشاركة قام بنشر أكتوبر 22, 2023 ماشاء الله هو المطلوب تمام جزاك الله كل خير 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان