محي الدين ابو البشر

استبدل With Sheets("Sheet3").PageSetup .FitToPagesWide = 1 .FitToPagesWide = False End With بـ With Sheets("Sheet3").PageSetup .Zoom = 100 End With

أخي الكريم اليك بعض الأمثلة لتحديد النطاق الذي تريد Cells(1, 1).Resize(5, 10).SpecialCells(2, 23).ClearContents Range("A1:H50").SpecialCells(2, 23).ClearContents Cells(1, 1).CurrentRegion.SpecialCells(2, 23).ClearContents أما 2و23 فلهما علاقة بالقيم الثابتة أرقام ونصوص و ...

ربما Private Sub Workbook_Open() Range("U2") = Evaluate("=EOMONTH(TODAY(),-2)+1") Range("V2") = Evaluate("=DAY(DATE(YEAR($U$2),MONTH($U$2)+1,0))") Range("J5") = Evaluate("=UPPER(TEXT(U2,""[$-40c] mmmm yyyy""))") x = 0 For i = 12 To 42 Range("M" & i) = Evaluate("=IF(1<=V" & 2 & ",IF(OR(TEXT(U" & 2 + x & ",""DDDD"")=""friday"",TEXT(U2+" & x & ",""DDDD"")=""saturday""),0,1),"""")") Range("N" & i) = Evaluate("=IF(1<=V" & 2 & ",IF(OR(TEXT(U" & 2 + x & ",""DDDD"")=""friday"",TEXT(U2+" & x & ",""DDDD"")=""saturday""),0,1),"""")") Range("C" & i) = Evaluate("=IF(M" & i & "=1,""08H00"","""")") x = x + 1 Next Range("A40") = Evaluate("=IF(V2>=29,29,"""")") Range("A41") = Evaluate("=IF(V2>=30,30,"""")") Range("A42") = Evaluate("=IF(V2>=31,31,"""")") Range("E40") = Evaluate("=IF(AND(A40>=29,N40=0),""R.H"","""")") Range("E41") = Evaluate("=IF(AND(A41>=30,N41=0),""R.H"","""")") Range("E42") = Evaluate("=IF(AND(A42>=31,N42=0),""R.H"","""")") End Sub

الخلايا التي فيها قيم ثابتة

اقتراح المصنف1 (1).xlsx

Sub test() Cells(1).SpecialCells(2, 23).ClearContents End Sub

Sub MyStuNames() On Error Resume Next Application.ScreenUpdating = False Set rng1 = Worksheets("StudNames"): Set rng2 = Worksheets("Analysis") S = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "-" & Right(rng2.[AB1], 1): t = rng2.[AB1] S2 = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "/" & Right(rng2.[AB1], 1): t2 = rng2.[AB1] X = Application.CountIf(rng1.Range("B:B"), S) + Application.CountIf(rng1.Range("B:B"), t) + Application.CountIf(rng1.Range("B:B"), S2) Y = IIf(Range("LangCod") = 2, 5, 4) rng2.Range("B8:C42") = Empty For i = 1 To X rng2.Cells(7 + i, "B").Value = i For Each cel In rng1.Range("B2:B5000") If (cel = S Or cel = t Or cel = t1) And cel.Offset(0, -1) = i Then _ rng2.Cells(7 + i, "C").Value = rng1.Cells(cel.Row, Y).Value Next Next Application.ScreenUpdating = True End Sub هكذا؟

ربما test.xlsx

بارك الله

السلام عليكم عسى يكون المطلوب الغياب.xlsm

السلام عليكم هناك مشكلة استبدل كل sheet1 بـ Sheets("sheet1") وكل sheet2 بـ Sheets("sheet2") اينما حلت دائماً وأبداً بليز Codes.xlsm

السلام عليكم حاول End If ورقة6.Range("A2").Resize(m - 1).FillDown ورقة6.Range("H2").Resize(m - 1).FillDown ورقة6.Range("I2").Resize(m - 1).FillDown ورقة6.Range("M2").Resize(m - 1).FillDown End Sub

Again Sheets("Sheet2").Cells(M, "A").Value = Sheets("Sheet1").Range("F6").Value لا حظ ("Sheets("sheet1 Sheets("sheet2").Cells(M, "A").Value = Sheets("sheet1").Range("F6").Value Sheets("sheet2").Cells(M, "B").Value = Sheets("sheet1").Range("F8").Value Sheets("sheet2").Cells(M, "C").Value = Sheets("sheet1").Range("F10").Value Sheets("sheet2").Cells(M, "D").Value = Sheets("sheet1").Range("F12").Value Sheets("sheet2").Cells(M, "E").Value = Sheets("sheet1").Range("I6").Value Sheets("sheet2").Cells(M, "F").Value = Sheets("sheet1").Range("I8").Value Sheets("sheet2").Cells(M, "G").Value = Sheets("sheet1").Range("I10").Value Sheets("sheet2").Cells(M, "H").Value = Sheets("sheet1").Range("I12").Value Sheets("sheet1").Range("F6").Value = "" Sheets("sheet1").Range("F8").Value = "" Sheets("sheet1").Range("F10").Value = "" Sheets("sheet1").Range("F12").Value = "" Sheets("sheet1").Range("I6").Value = "" Sheets("sheet1").Range("I8").Value = "" Sheets("sheet1").Range("I10").Value = "" Sheets("sheet1").Range("I12").Value = "" الأفصل Set sh1 = Sheets("sheet1") Set sh2 = Sheets("sheet2") M = Sheets("Sheet2").Range("A1").End(xlDown).Row+1 sh2.Cells(M, "A").Value = sh1.Range("F6").Value sh2.Cells(M, "B").Value = sh1.Range("F8").Value sh2.Cells(M, "C").Value = sh1.Range("F10").Value sh2.Cells(M, "D").Value = sh1.Range("F12").Value sh2.Cells(M, "E").Value = sh1.Range("I6").Value sh2.Cells(M, "F").Value = sh1.Range("I8").Value sh2.Cells(M, "G").Value = sh1.Range("I10").Value sh2.Cells(M, "H").Value = sh1.Range("I12").Value sh1.Range("F6").Value = "" sh1.Range("F8").Value = "" sh1.Range("F10").Value = "" sh1.Range("F12").Value = "" sh1.Range("I6").Value = "" sh1.Range("I8").Value = "" sh1.Range("I10").Value = "" sh1.Range("I12").Value = "" و ممكن

السلام عليكم جرب M = Sheets("Sheet2").Range("A1").End(xlDown).Row

(كود) لعله يكون المطلوب Sub test() d = Split(Join(Application.Transpose(Sheets("Excursion").Range(Sheets("Excursion").Range("C2"), Sheets("Excursion").Range("C2").End(xlDown))), "#") & "#" _ & Join(Application.Transpose(Sheets("Shopping").Range(Sheets("Shopping").Range("C4"), Sheets("Shopping").Range("C4").End(xlDown))), "#") & "#" _ & Join(Application.Transpose(Sheets("Bonus").Range(Sheets("Bonus").Range("B4"), Sheets("Bonus").Range("B4").End(xlDown))), "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(d) If Not .exists(d(i)) Then .Add d(i), .Count + 1 End If Next Sheets("Total").Cells(2, 3).Resize(.Count) = Application.Transpose(.keys) End With End Sub

حسب ما فهمت السؤال Sub test() Cells(147, 2).Resize(4, 6) = Application.Transpose(Application.Index(Cells(1). _ CurrentRegion, Array(8, 15, 17, 18), Evaluate("row(1:6)"))) Cells(147, 1).Resize(4) = Evaluate("row(1:6)") End Sub

الحمد لله الذي بنعمته تتم الصالحات

معك حق تفضل أخي الكريم Vente-4.xlsm

تفضل أخي الكريم Vente (1).xlsm

اخي العزيز جرب خذا الملف وهو تعديل على ما سبق Vente.xlsm

عند نسخ الصفحة يجب ان تنقل إلى النهاية إليك الملف AA.xlsm

Sub test() Dim count As Long With Sheets(1) On Error Resume Next count = InputBox("أدخل العدد المطلوب", "دخال") If count <> 0 Then a = Application.Transpose(Array(Application.Transpose(Evaluate("row(1:" & count & ")")) _ , Application.Transpose(.Cells(1, 1).Resize(count)))) With Sheets(2) .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Resize(, 9).ClearContents r = 1 For i = 0 To count / 3 Step 21 For ii = 1 To 8 Step 3 .Cells(2 + i, ii).Resize(21, 2) = WorksheetFunction.IfError(Application.Index _ (a, Evaluate("row(" & r & ":" & 21 + r & ")"), Array(1, 2)), "") r = r + 21 Next: Next End With Else: MsgBox "أدخل عدد", vbCritical, "خطأ بالإدخال" End If End With End Sub في حال خطأ في الإدخال

أخي العزيز في الملف السابق يتم التحديد من الشيت الأول الخلية F1 على كل استبدل الكود بهذا الكود وهو محدث عم السابق و... عسى يكون المطلوب Sub test() Dim count As Long With Sheets(1) count = InputBox("أدخل العدد المطلوب", "دخال") a = Application.Transpose(Array(Application.Transpose(Evaluate("row(1:" & count & ")")) _ , Application.Transpose(.Cells(1, 1).Resize(count)))) With Sheets(2) .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Resize(, 9).ClearContents r = 1 For i = 0 To count / 3 Step 21 For ii = 1 To 8 Step 3 .Cells(2 + i, ii).Resize(21, 2) = WorksheetFunction.IfError(Application.Index _ (a, Evaluate("row(" & r & ":" & 21 + r & ")"), Array(1, 2)), "") r = r + 21 Next: Next End With End With End Sub AA.xlsm

ممكن مساعدتك هنا إذ أحببت بدون مقابل

ولكم مثل ما ذكرتم