حسين مامون

اليك هذا 
عند اختيار الصنف يتم الاستعلام عن الصنف المختار
وعند اختيار المقاس يستعلم عن المقاس والنتيجة تظهر الماركة و السعر و الكادر و مواصفات
ولكن لازم تختار الصنف اولا ...ومرة اخرى الخلايا المدمجة لازم تحدفها ...تحياتي
التعديل المطلوب (1).xlsm

اخي الكريم munear
جرب المرفق ..ادخل المودييل اولا ثم تاريخ الاستلام
تثبيت معادلة.xlsm

جرب هذه الطريق لعلها تفيدك
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim h1, h2, dt1, dt2 If Not Intersect(Target, Range("k2:k1000")) Is Nothing Then h2 = Target h1 = Format(Target.Offset(, -2), "dd-mm-yyyy") & " " & Format(Target.Offset(, -1), "hh:mm:ss") Target.Offset(, 1) = Format(DateAdd("h", h2, h1), "mm-dd-yyyy hh:mm:ss") End If If Target = Empty Then Target.Offset(, 1).ClearContents End Sub add hour to date.xlsm

بما انك لم ترفع ملف او صورة تحاكي طلبك اليك هذه التجربة المتواضعة
عليك بالضغط على الزر كلما فتحت الملف
Option Explicit Sub dt() Dim dt, dt1, dt2 With Sheets(1) Range("j4") = Range("j6") Set dt = Range("j4") Set dt1 = .Range("j6") Set dt2 = .Range("k6") .Range("j6") = Date If dt1 = "" Then Exit Sub Else dt2 = Format(DateAdd("d", 1, dt1), "d") - Format(DateAdd("d", 1, dt), "d") .Range("k6") = Val(.Range("k6")) + dt2 Exit Sub End If End With End Sub test1.xlsm

ان لم تستطيع اليك هذا
Sub test() Dim lr, f, f2, f3, f4, f5, f6 f = "=IF(ISERROR" & "(MATCH($A3,OFFSET" & "(INDIRECT(ADDRESS" & "(1,1,,,B$2)),,,1000,1),0))" & "," & """لم يدخل""" & "," & """دخل""" & ")" f2 = "=IF(ISERROR" & "(MATCH($A3,OFFSET" & "(INDIRECT(ADDRESS" & "(1,1,,,C$2)),,,1000,1),0))" & "," & """لم يدخل""" & "," & """دخل""" & ")" f3 = "=IF(ISERROR" & "(MATCH($A3,OFFSET" & "(INDIRECT(ADDRESS" & "(1,1,,,D$2)),,,1000,1),0))" & "," & """لم يدخل""" & "," & """دخل""" & ")" f4 = "=IF(B3=""دخل"",INDIRECT(ADDRESS(MATCH($A3,OFFSET(INDIRECT(ADDRESS(1,1,,,F$2)),,,1000,1),0),2,,,F$2)),"""")" f5 = "=IF(C3=""دخل"",INDIRECT(ADDRESS(MATCH($A3,OFFSET(INDIRECT(ADDRESS(1,1,,,G$2)),,,1000,1),0),2,,,F$2)),"""")" f6 = "=IF(D3=""دخل"",INDIRECT(ADDRESS(MATCH($A3,OFFSET(INDIRECT(ADDRESS(1,1,,,H$2)),,,1000,1),0),2,,,F$2)),"""")" lr = Cells(Rows.Count, 1).End(xlUp).Row Range("b3:b" & lr).Formula = f Range("C3:C" & lr).Formula = f2 Range("D3:D" & lr).Formula = f3 Range("f3:f" & lr).Formula = f4 Range("g3:g" & lr).Formula = f5 Range("h3:h" & lr).Formula = f6 Range("b3:h" & lr).Value = Range("b3:h" & lr).Value End Sub  

تفضل 
طباعة اللاصقات1.xlsm

السلام عليكم ورحمة الله
حاول تطبيق الماكرو في هذا الملف على الملف لديك
حسين.xlsm

جرب التعديل في هذا الملف
نموذج (1).xlsm

جرب هذا الشيء
Book1 (1).xlsm

السلام عليكم ورحمة الله .. .ربما تقصد ما في هذه التجربة المتواضعة
112.xlsm

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

جرب الكود التالي
Option Explicit Sub PRINT1() Dim DT, dt2 Dim RG Dim x DT = Sheets("ST").Range("c3"): dt2 = DT RG = Sheets("ST").Range("e3") For x = 1 To RG Sheets("P.R.T").Range("b3") = dt2 Sheets("P.R.T").PrintOut Copies:=x, Collate:=True, _ IgnorePrintAreas:=False dt2 = Format(DateAdd("m", 1, dt2), "yyyy-mm-dd") Next End Sub  
تجربه الطباعه.xlsm

تفضل
 
فاتورة .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

تفضل
 
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

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

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

ربما هكذا
Sub ÍÐÝ() Range("A6:B220").Select Selection.Delete Range("A6:B220").Formula = "=COUNTA(B6:B220)" End Sub  

تفضل
ترحيل (2).xlsm

تفضل
click.xlsm

هذه محاولة