حسين مامون

جرب المحاولة دي 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

جرب ورد تكرار -عدد - قيمة1.xlsm

اخي الكريم الملف شغال في حدث فتح يعني عند فتح الملف ينفذ اذا كان التاريخ في الجهاز مطابق للتاريخ في الكود ملاحظة يمكنك تغيير التاريخ في الكود حسب ما تريد قرعة.xlsm

المرفق فيه تجربة مماثلة لما تقول يعني الملف الرئيسي المسمى test1 من خلاله تفتح فورم ومن الفورم يمكنك فتح ملف اي عميل حسب الكود كل الملفات مخزنة في مجلد ma boite قم بفك الضغط وضع المجلف في اس فولدر تريد هذا يختصر لك عملية البحث عن ملف داخل مجلد فيه اكثر من ملف يمكنك اجراء تعديل على ملفك كما في هذا الملف جرب ورد ... تحياتي ma boite.rar

اخي الكريم فتحت ملفك اكثر من مرة ولكن لم افهم طلبك اظن ينقصك المزيد من التوضيح حاول شرح ما تريد بلغة الاكسيل مثلا: اريد ترحيل البيانات بناء على كذا في تيكست بوكس كذا او خلية كذا في الشيت كذا حاول ادخال بيانات يدويا في الفورم كما تتصورها وارفع صورة لذلك. ونفس الشيء للشيت الهدف