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

تفضل أخي الكريم pr.xlsm

بارك الله

استبدل الاكواد Option Explicit Sub Test() Dim a, b, x Dim i, ii Dim nmsht, dt, bk Dim p As Long Dim ar As Long Dim tmp, class, br, mat Const c As Integer = 25 Set nmsht = Sheets("name") Set dt = Sheets("data") Set bk = Sheets("Book") b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3) p = 4: For i = 1 To UBound(b) tmp = Split(b(i, 1)) class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2)) br = tmp(UBound(tmp)): mat = b(i, 3) With nmsht.Range("b2:AX400") x = .Find(b(i, 1), , , 1).Address a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1) End With ar = 1 With Sheets("book") For ii = 1 To UBound(a) Step c x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2) .Cells(x - 6 - c, 4) = .Cells(x - 6 - c, 4) & " " & class .Cells(x - 6 - c, 9) = .Cells(x - 6 - c, 9) & " " & br .Cells(x - 6 - c, 15) = mat .Cells(x - 1 - c, 1).Resize(c, 2) = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "") ar = ar + c p = p + 2 Next End With Next End Sub و Private Sub CommandButton1_Click() Dim r As Range With Sheets("Book") On Error Resume Next For Each myArea In .Columns(1).SpecialCells(2, 1).Areas myArea.Resize(, 2).ClearContents myArea.Offset(-5, 3).Resize(1) = Split(myArea(-4, 4))(0) myArea(-4, 9) = Split(myArea(-4, 9))(0) myArea(-4, 15) = "" Next End With End Sub

ترحيل اسم المادة!!! ليس بإضافة أسطر خيراً إن شاء الله

لا صورة سأبقى معك حتى تحل كل المشاكل ؟؟؟؟؟؟؟؟؟؟؟

آسف جدا .. My mistack كتيب العلامات2.xlsm

تفضل أخي الكريم كتيب العلامات2.xlsm

عليكم السلام بالنسبة للملاحظة 3 الكود يعمل بشكل صحيح حسب آخر ملف أرسلته "مثال معدل" على كل تانظر المرفقوأعلمني بالنسبة للملاحظات 1و2 ساعمل عليها بإذن الله كتيب العلامات2.xlsm

تفضل أخي عسى يكون المطلوب Sub Test() Dim a, b, x Dim i, ii Dim nmsht, dt, bk Dim p As Long Dim ar As Long Const c As Integer = 25 Set nmsht = Sheets("name") Set dt = Sheets("data") Set bk = Sheets("Book") b = Application.Transpose(dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown))) p = 4: For i = 1 To UBound(b) With nmsht.Range("b2:AX400") x = .Find(What:=b(i), After:=Range("B2"), lookat:=xlWhole, SearchDirection:=xlNext).Address a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1) End With ar = 1 With Sheets("book") For ii = 1 To UBound(a) Step 25 x = Split(.[E:E].Find(What:="-" & p & "-", After:=Range("E2"), lookat:=xlWhole, SearchDirection:=xlNext).Address, "$")(2) .Cells(x - 1 - c, 1).Resize(c, 2) = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "") ar = ar + c p = p + 2 Next End With Next End Sub

السيد محمد عدنان ممكن أن ترفع بعض النتائج في شيت book مثلا للعاشر أ والحادي عشر ب (أن تملاها يدويا) شكراً

بارك الله

Sheets("Sheet1").Cells(1,1) = Me.TextBox1.Value & " " + Me.TextBox2.Value في الخلية A1?

في الشيت 1 مثلا يمكن Sub test() Sheets("sheet1").Cells.SpecialCells(xlCellTypeConstants, 2).Select End Sub

السلام عليكم ما رأيك بـ s = InputBox("Start form?") e = InputBox("To?") For i = s To e ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\Users\Ahmed\Desktop\" & i & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False Next

بارك الله

عسى ولعل تقرير العمل.xlsm

الحمد لله

عسى تكون المطلوب Private Sub Workbook_Open() Range("C12:N42").ClearContents 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""))") For i = 0 To Range("V2").Value - 1 Range("M" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("N" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("C" & 12 + i) = Evaluate("=IF(M" & 12 + i & "=1,""08H00"","""")") Range("F" & 12 + i) = Evaluate("=IF(M" & 12 + i & "=1,""16H30"","""")") Range("E" & 12 + i) = Evaluate("=IF(N" & 12 + i & "=0,""R.H"","""")") Next 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"","""")") Range("A40") = Evaluate("=IF(V2>=29,29,"""")") Range("A41") = Evaluate("=IF(V2>=30,30,"""")") Range("A42") = Evaluate("=IF(V2>=31,31,"""")") End Sub

Sorry 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""))") For i = 0 To 42 - 13 Range("M" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("N" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("C" & 12 + i) = Evaluate("=IF(M" & 12 + i & "=1,""08H00"","""")") Range("F" & 12 + i) = Evaluate("=IF(M" & 12 + i & "=1,""16H30"","""")") If i <= 39 Then Range("E" & 12 + i) = Evaluate("=IF(N" & 12 + i & "=0,""R.H"","""")") Next 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"","""")") Range("A40") = Evaluate("=IF(V2>=29,29,"""")") Range("A41") = Evaluate("=IF(V2>=30,30,"""")") Range("A42") = Evaluate("=IF(V2>=31,31,"""")") End Sub

ممكن تجرب 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""))") For i = 0 To 42 - 13 Range("M" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("N" & 12 + i) = Evaluate("=IF(1<=$V$2,IF(OR(TEXT($U$2+" & i & ",""DDDD"")=""friday"",TEXT($U$2+" & i & ",""DDDD"")=""saturday""),0,1),"""")") Range("C" & 12 + i) = Evaluate("=IF(M" & 12 + i & "=1,""08H00"","""")") Next 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"","""")") Range("A40") = Evaluate("=IF(V2>=29,29,"""")") Range("A41") = Evaluate("=IF(V2>=30,30,"""")") Range("A42") = Evaluate("=IF(V2>=31,31,"""")") End Sub

بارك الله

في هذه الحالة Sub test() Sheets("4").Cells(1).CurrentRegion.Offset(1).SpecialCells(2, 23).ClearContents End Sub عمود الفرقة ليس معادلات ليس يتم مسحه بعض العديلات+ ملف.xlsm

بارك الله بك

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