اذهب الي المحتوي
أوفيسنا

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

الخبراء
  • Posts

    878
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    6

كل منشورات العضو محي الدين ابو البشر

  1. استبدل الاكواد 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
  2. ترحيل اسم المادة!!! ليس بإضافة أسطر خيراً إن شاء الله
  3. لا صورة سأبقى معك حتى تحل كل المشاكل ؟؟؟؟؟؟؟؟؟؟؟
  4. آسف جدا .. My mistack كتيب العلامات2.xlsm
  5. تفضل أخي الكريم كتيب العلامات2.xlsm
  6. عليكم السلام بالنسبة للملاحظة 3 الكود يعمل بشكل صحيح حسب آخر ملف أرسلته "مثال معدل" على كل تانظر المرفقوأعلمني بالنسبة للملاحظات 1و2 ساعمل عليها بإذن الله كتيب العلامات2.xlsm
  7. تفضل أخي عسى يكون المطلوب 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
  8. السيد محمد عدنان ممكن أن ترفع بعض النتائج في شيت book مثلا للعاشر أ والحادي عشر ب (أن تملاها يدويا) شكراً
  9. Sheets("Sheet1").Cells(1,1) = Me.TextBox1.Value & " " + Me.TextBox2.Value في الخلية A1?
  10. في الشيت 1 مثلا يمكن Sub test() Sheets("sheet1").Cells.SpecialCells(xlCellTypeConstants, 2).Select End Sub
  11. السلام عليكم ما رأيك بـ 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
  12. عسى تكون المطلوب 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
  13. 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
  14. ممكن تجرب 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
  15. في هذه الحالة Sub test() Sheets("4").Cells(1).CurrentRegion.Offset(1).SpecialCells(2, 23).ClearContents End Sub عمود الفرقة ليس معادلات ليس يتم مسحه بعض العديلات+ ملف.xlsm
  16. استبدل With Sheets("Sheet3").PageSetup .FitToPagesWide = 1 .FitToPagesWide = False End With بـ With Sheets("Sheet3").PageSetup .Zoom = 100 End With
×
×
  • اضف...

Important Information