حسين مامون

اخي الكريم حاولت مساعدتك ولكن لم اتوصل لحل لما تريد ربما يتقدم احد الاخوة بفكرة اخرى تحياتي

اليك المرفق ان اعجبك نتابع ونكمل باقي الحاجيات تحياتي asso.xlsm

اليك هذا ربما تستفيد منه addDT.xlsm

تفضل فاتورة .xlsm

جرب المحاولة دي test (3).xlsm

الحمد لله ان تم الامر وجزيت خيرا اخي الكريم

هذا الكود يطبع بطابعتية مختلفتين ولكن ل ادري هل بامكانك عمل مجهود للحصول على اسماء الطابعتين لديك Sub print1() Dim s, u s = "Canon MF3010 sur Ne07:" ' اسم الطابعة الاولى u = "HP LaserJet P1005 sur Ne03:" 'اسم الطابعة الثانية '=============== Application.ActivePrinter = s Range("a1:e10").PrintOut ' الطباعة بالطابعة الاولى '=============== Application.ActivePrinter = u Range("a1:e10").PrintOut ' الطباعة بالطابعة الثانية End Sub وهذا الرابط للحصول على اسم الطابعة

بعد ادن الاستاد جرب المرفق المصنف1 (2).xlsm

Sub MyPrint() Dim i Application.ScreenUpdating = False With Sheets(" Print_Report") With .Range("B10:I20") For i = 1 To .Rows.Count If .Cells(i, 1).Value = "" Then .Cells(i, 1).EntireRow.Hidden = True End If Next i End With '========================== Application.Dialogs(xlDialogPrinterSetup).Show '========================== .PrintOut .Rows.Hidden = False End With Application.ScreenUpdating = True End Sub

تجربة ربما تفيدك نفس الكود السابق مع بعض التغييرات انظر الملف Option Explicit Sub test1() Dim lr Dim x, r Dim dt1, dt2 dt1 = Date lr = Cells(Rows.Count, "h").End(3).Row Range("i5:i1000").ClearContents For x = 5 To lr dt2 = CDate(Cells(x, "h")) Cells(x, "i").Value = "no" Select Case Cells(x, "h").Value2: Case dt1 To dt2 Cells(x, "i").Value = "ok" End Select Next x End Sub test مياوم.xlsm

يمكنك اختيار طابعة عن طريق هذا الكود انسخه الى ملفك وانشئ زر لتنفيده Option Explicit Sub choiprinTEST() Application.Dialogs(xlDialogPrinterSetup).Show End Sub

السلام عليكم بعد ادن الاستاد ابو عيد طريقة اخرى قريبة من طلبك ب VBA اتمنى ان يفيدك Option Explicit Sub test1() Dim lr Dim x, r Dim dt1, dt2 dt1 = CDate(Range("b4")) dt2 = CDate(Range("b5")) If dt1 = 0 Then MsgBox "ادخل التاريخ من", vbInformation: Exit Sub If dt2 = 0 Then MsgBox "ادخل التاريخ الى", vbInformation: Exit Sub r = 9 Range("f9:h1000").ClearContents lr = Cells(Rows.Count, 1).End(3).Row For x = 9 To lr Select Case Cells(x, 2).Value2: Case dt1 To dt2 Cells(x, 1).Resize(, 3).Copy Range("f" & r) r = r + 1 End Select Next x End Sub دالة if.xlsm

عليكم السلام ورحمة الله ربما هذا الكود في حدث الشيت يفي بالغرض Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim Rng Set Rng = Range("j1:j100000") If Not Intersect(Target, Rng) Is Nothing Then If Target = "" Then Target.Offset(, -9).Resize(1, 10).Interior.Color = xlNone ElseIf Target <= 5 Then Target.Offset(, -9).Resize(1, 10).Interior.Color = 10086143 ElseIf Target <= 10 Then Target.Offset(, -9).Resize(1, 10).Interior.Color = 8420607 ElseIf Target Then Target.Offset(, -9).Resize(1, 10).Interior.Color = 10479044 End If End If End Sub

بعد ادن استاد محمد صلاح واتراء للموضوع .. جرب هذا الكود Option Explicit Sub RCT() Dim Ws As Worksheet Dim Ws2 As Worksheet Dim lr1, lr2 Dim x, y Dim arr Set Ws = Sheets("po_rec") Set Ws2 = Sheets("recept") Application.ScreenUpdating = False With Ws lr1 = .Cells(Rows.Count, 1).End(3).Row arr = Array("recept1", "recept2", "recept3", "recept4", "recept5", "recept6") For x = 5 To lr1 For Each y In arr If .Cells(x, 14).Text = "ok" Then GoTo 1 If .Cells(x, 13).Text = y Then Ws2.Cells(3, 2).Value = .Cells(x, 1) Ws2.Cells(4, 2).Value = .Cells(x, 2) Ws2.Cells(5, 2).Value = .Cells(x, 3) Ws2.Cells(6, 2).Value = .Cells(x, 5) Ws2.Cells(7, 2).Value = .Cells(x, 6) Ws2.Cells(8, 2).Value = .Cells(x, 8) Ws2.Cells(21, 2).Value = .Cells(x, 13) .Cells(x, 14) = "ok": GoTo 1 If y = "recept6" Then Exit Sub End If Next y 1: Next x End With Application.ScreenUpdating = True End Sub الملف refill.xlsm

هذا ما يقوم به الكود بالظبط يعني عند الضغط على الزر يطبع مرس واحد ويمر لطباعة الاخرى وهكذا حتى النهاية

تفضل الكود Option Explicit Sub PRINT_OUT() Dim ws As Worksheet Set ws = Sheets("Renew Report") Dim lr As Long Dim x Application.ScreenUpdating = False lr = ws.Cells(Rows.Count, 3).End(3).Row With Sheets("renew") For x = 2 To lr .Range("G8").Value = ws.Cells(x, "b") .Range("B4").Value = ws.Cells(x, "c") .Range("B8").Value = ws.Cells(x, "d") .Range("G12").Value = ws.Cells(x, "k") .Range("B14").Value = ws.Cells(x, "r") .Range("a1:h26").PrintOut If .Range("G8") = "" Then Exit For Next x End With Application.ScreenUpdating = True End Sub الملف Ù_ادÙ_ اÙ_Ø®Ù_راÙ_ Ù_Ù_Ù_Ø®Ù_ت.xlsm

اخي الكريم يستحسن شرح ما تريد بوضع النتيجة المتوقعة يدويا في ملفك وارفعه مرة اخرى تحياتي

انسخ هذا الماكرو واربطه بالزر Option Explicit Sub test() Dim rg With Sheets("Sheet1") rg = .Range("a" & Rows.Count).End(3).Row Sheets("Sheet2").Range("a1:c1000").ClearContents Sheets("Sheet2").Range("a1:c1000").Borders.LineStyle = 0 .Range("a:a").Resize(rg, 3).Copy Sheets("Sheet2").Range("a1") .Range("$B$1:$B$16").AutoFilter Field:=1 End With End Sub

تفضل CLASSEUR11.xlsm

تفضل بالنسبة لطلبك الثاني لم افهم ما تقصد بكتابة اللجنة في نفس سطر المجموع يمكنك رفع نمودج متوقع لما تريد CLASSEUR11.xlsm

جرب المرفق Option Explicit Sub test() Dim lr Dim x Dim n, tot Application.ScreenUpdating = False lr = Cells(Rows.Count, 2).End(xlUp).Row For x = 2 To lr tot = tot + Val(Cells(x, "f")) If Val(Cells(x, 2).Offset(1)) > Val(Cells(x, 2)) Then Cells(x, 1).Offset(1).Resize(, 6).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Cells(x, "f").Offset(1).Value = tot Cells(x, "E").Offset(1).Value = "المجموع" x = x + 1 tot = 0 End If Next x Application.ScreenUpdating = True End Sub CLASSEUR11.xlsm

انسخ هذا السطر والصقه On Error Resume Next بعد السطر الثاني في الكود

تفضل pro-1.xlsm

تفضل انظر المرفق اي تغيير في المدى (B4:F100000) تتجده في الصفحة الاخرى Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim adrs adrs = Target.Address If Not Intersect(Target, Range("b4:f100000")) Is Nothing Then Sheets("Sheet2").Range(adrs) = Target End If End Sub pro-1.xlsm

جرب هذا الماكرو Option Explicit Sub test() Dim x x = InputBox("حدد المدى كالنمودج هنا b1:b10") If x = "" Then Exit Sub ActiveSheet.Range(x).Select End Sub الملف t.xlsm او هذا الماكرو حيث تدخل المدى الى فقط مثلا نكتب BD120 T فقط سيحدد من BD12:DB120 Sub test() Dim x, y y = "bd12:" x = y & InputBox("ادخل المدى الى مثلا bd111") If x = "" Then Exit Sub ActiveSheet.Range(x).Select End Sub الملف t.xlsm