حسين مامون

جرب هذه الطريق لعلها تفيدك 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

بعد اذن الاستاد هشام واثراء للموضوع هذا حل اخر بالاكواد Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("Feuil2") Dim lr1, r Dim x1, x2 r = 2 Application.ScreenUpdating = False ws.Range("g2:j1000").ClearContents With Sheets("Feuil1") lr1 = .Cells(Rows.Count, 1).End(3).Row For x1 = 1 To 4 For x2 = 7 To 11 If .Cells(1, x1).Text = ws.Cells(1, x2).Text Then .Cells(2, x1).Resize(lr1).Copy ws.Cells(2, x2).Resize(lr1) GoTo 1 End If Next x2 1: Next x1 End With Application.ScreenUpdating = True End Sub Copie de TRANSFER-COLONE_Marcel32-v12.xlsm

بالنسبة للعد يمكنك استعمال هذه =COUNT(E1:E12) الطلب الثاني لم اتوصل بما تريد باستخدام التنسيق الشرطي ربما تكون فكرة اخرى من احد الاساتذة

في الماكرو غير هذه printout الى هذه PrintPreview

بعد ادن استادي Ali Mohamed Ali واتراء للموضوع هذه طريق اخرئ 1- حمل الملف وفك الضغط 2 بعد فتح ملف اكسيل حدد اسم ملف بدف واضغط الزر ملاحظة: يجب ان تخزن الملفات ب د ف في نفس الفولدر"oqoud" مع ملف اكسيل و اسمارها ايضا في الصفحة كما في المرفق oqoud.rar

تفضل طباعة اللاصقات1.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

هذا الكود يعمل على العمود B حاول تطبيقه على الاعمدة الاخرى Option Explicit Sub test() Dim lr, f f = "=IF(ISERROR" & "(MATCH($A3,OFFSET" & "(INDIRECT(ADDRESS" & "(1,1,,,B$2)),,,1000,1),0))" & "," & """لم يدخل""" & "," & """دخل""" & ")" lr = Cells(Rows.Count, 1).End(xlUp).Row Range("b3:b" & lr).Formula = f End Sub ربط جداول من اوراق اخرى.xlsm

بعد اذن الاستاذ محسن واتراء للموضوع طباعة نمودج1 Option Explicit Sub printCART() Dim WS As Worksheet: Set WS = Sheets("Feuil1") Dim WS1 As Worksheet: Set WS1 = Sheets("نموج1") Dim lr, x Dim rng1, rng2: Set rng1 = WS1.Range("d2:f22"): Set rng2 = WS1.Range("j2:l22") Dim C1, C2, C3, C4 Set C1 = WS1.Range("d2"): Set C2 = WS1.Range("d13") Set C3 = WS1.Range("j2"): Set C4 = WS1.Range("j13") Application.ScreenUpdating = False lr = WS.Cells(Rows.Count, "b").End(xlUp).Row rng1.ClearContents rng2.ClearContents If MsgBox("هل تريد طباعة المحتوى", vbInformation + vbYesNo) = vbYes Then For x = 2 To lr If C1 = "" Then WS1.[d2] = WS.Cells(x, 2) WS1.[d4] = WS.Cells(x, 3) WS1.[d6] = WS.Cells(x, 4) WS1.[d8] = WS.Cells(x, 5) WS1.[d10] = WS.Cells(x, 6) GoTo 1 End If If C2 = "" Then WS1.[d13] = WS.Cells(x, 2) WS1.[d15] = WS.Cells(x, 3) WS1.[d17] = WS.Cells(x, 4) WS1.[d19] = WS.Cells(x, 5) WS1.[d21] = WS.Cells(x, 6) GoTo 1 End If If C3 = "" Then WS1.[j2] = WS.Cells(x, 2) WS1.[j4] = WS.Cells(x, 3) WS1.[j6] = WS.Cells(x, 4) WS1.[j8] = WS.Cells(x, 5) WS1.[j10] = WS.Cells(x, 6) GoTo 1 End If If C4 = "" Then WS1.[j13] = WS.Cells(x, 2) WS1.[j15] = WS.Cells(x, 3) WS1.[j17] = WS.Cells(x, 4) WS1.[j19] = WS.Cells(x, 5) WS1.[j21] = WS.Cells(x, 6) WS1.Range("a1:l24").PrintOut: rng1.ClearContents: rng2.ClearContents GoTo 1 End If 1: Next x If C1 > 0 Or C2 > 0 Or C3 > 0 Or C4 > 0 Then WS1.Range("a1:l24").PrintOut End If End If Application.ScreenUpdating = True End Sub طباعة اللاصقات1.xlsm

بعد اذن الاستاد Ali Mohamed Ali ربما الاخ نسور الجو يقصد العمود B في صفحة قاعدة وهذه تجربة ...الكومبوبوكس2 دون تكرار wor1.xlsm

عندي بيرحل 100/100 لا ادري سبب المشكلة عندك

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

جرب المرفق نموذج (1).xlsm

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

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

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

من دون ملف عمل نمودج لما تريد صحب ايجاد حل ...............

جرب المرفق test test1.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

جرب المرفق قمت ببعض التغيير في الصفحة A التجميع بزر مرتبط بكود VBA معمول بحلقات تكرارية الزر في صفحة B اتمنى ان يكون ما تريد ترحيل ودمج البيانات بشرط.xlsm

جربها هكذا ضع نعم بين علامتي تنصسص "نعم" و صفر "0" ان لم تعمل فعليك الغاء القائمة المنسدلة وادخال الكلمتين يدوي

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

تفضل Sub test() Dim RG1, RG2 Dim r, x Set RG1 = [D3]: Set RG2 = [E3] r = 2 Application.ScreenUpdating = False If RG1 > 51 Then MsgBox "ادخل فقط من 1 الى50", vbExclamation: Exit Sub If RG2 > 100 Then MsgBox "لا يمكن ادخال اكبر من 100", vbExclamation: Exit Sub Range("j2:j1000000").ClearContents For x = RG1 To RG2 Range("j" & r).Value = x r = r + 1 Next x Application.ScreenUpdating = True End Sub مسلسل.xlsm