حسين مامون

ThisWorkbook.Sheets("sheet3").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "oo", OpenAfterPublish:=True

Private Sub Worksheet_Change(ByVal Target As Range) ' ' On Error Resume Next If Not Intersect(Target, Range("a2:a10000")) Is Nothing Then Target.Offset(, 1) = Format(Date, "dd-mm-yyyy") End If End Sub ضع الكود في حدث الشيت ادخال البيانات في العمود 1 ويظهر التاريخ في العمود2

جرب المرفق معلومات فنية اتصالات.xlsm

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

بعد اذن اساتذتي الكرام و لاثراء الموضوع كود بالحلقات التكرارية Sub test() Dim lr1, lr2 Dim x, x2 Dim tot tot = 0 Application.ScreenUpdating = False With Sheets("Sheet1") lr1 = .Cells(Rows.Count, 1).End(3).Row lr2 = .Cells(Rows.Count, "i").End(3).Row For x2 = 2 To lr2 For x = 2 To lr1 If Format(.Cells(x2, "i"), "mm-yyyy") = Format(.Cells(x, 1), "mm-yyyy") Then tot = tot + .Cells(x, 2) End If Next x .Cells(x2, "j") = tot tot = 0 Next x2 End With Application.ScreenUpdating = True End Sub SUM_2.xlsm

ربما يفيدك هذا الفيديو للاستاذ المحترم عماد غازي

ضع هذا في حدث الفورم خاص لتعبئة تيكسبوكس53 اخر خلية العمود 1 sheet1 Private Sub UserForm_Initialize() Dim lr With Sheets("Sheet1") lr = .Cells(Rows.Count, 2).End(xlUp).Row TextBox53.Value = .Range("b" & lr).Offset(, -1) End With End Sub وهذا في حدث الشيت1 لادراج مسلسل Private Sub Worksheet_Change(ByVal Target As Range) Dim lr lr = Cells(Rows.Count, 2).End(3).Row If Intersect(Target, Range("a" & lr)) Is Nothing Then Range("a11:a" & lr).Formula = "=IF(B11="""","""",SUBTOTAL(103,$B$11:B11))" End If End Sub yousef (1).xlsb

ربما هذا الكود ينفذ ما تقصد كهرباء المخيم.xlsm

الاكواد داخل فورم اضفته في ملفك yousef.xlsb

ملفك سليم مفتوح بدون كلمة مرور ولا حاجة اظن المشكلة في جهازك المشكلة.xlsm

جرب المرفق تقرير.xlsm

انظر الملف نسبة.xlsx

تفضل كود vba Option Explicit Sub test() Dim ws As Worksheet Dim ws2 As Worksheet Set ws = Sheets("ÇáãÕÑæÝ") Set ws2 = Sheets("ÇáÍÇáÉ") Dim lr, X, R1, R2 ws2.Range("g2:q10000").ClearContents R1 = 2 R2 = 2 lr = ws.Cells(Rows.Count, 2).End(3).Row For X = 2 To lr If ws.Cells(X, 2).Text = "ÎÇÕ" Then ws2.Range("g" & R1).Value = ws.Cells(X, 2).Value ws2.Range("g" & R1).Offset(, 1).Value = ws.Cells(X, 4) & "/ " & ws.Cells(X, 5) ws2.Range("g" & R1).Offset(, 2).Value = ws.Cells(X, 9) ws2.Range("g" & R1).Offset(, 3).Value = ws.Cells(X, 10) ws2.Range("g" & R1).Offset(, 4).Value = ws.Cells(X, 11) R1 = R1 + 1 Else ws2.Range("m" & R2).Value = ws.Cells(X, 2).Value ws2.Range("m" & R2).Offset(, 1).Value = ws.Cells(X, 4) & "/ " & ws.Cells(X, 5) ws2.Range("m" & R2).Offset(, 2).Value = ws.Cells(X, 9) ws2.Range("m" & R2).Offset(, 3).Value = ws.Cells(X, 10) ws2.Range("m" & R2).Offset(, 4).Value = ws.Cells(X, 11) R2 = R2 + 1 End If Next X End Sub المنتوج+المحور+الاستحقاق.xlsm

كان عليك رفع ملف فيه شرح كافي ولكن ربما تستفيد من هذا الملف TEST22.xlsm

جزيت خيرا اخي الكريم

تفضل اختر من الكومبوبوكس اي اسم ثم اختر من الليست عدل ما تشاء واضغط زر تعديل بحث بمعيار الأسم ثم معيار التاريخ-1.xlsb

اخي الكريم لما لا تضيف ليستبوكس للفورم وهكذا تبحث عن الاسم فقط وياتيك بهذا الاسم ثم تختار ما تيد في الليستبوكس (اقتراح فقط) هكذا كمثال

جزاك الله خيرا غير هذا السطر ws.Range("g2:g" & lr1).Copy wb.Worksheets(1).Range("g" & lr2) بهذا ws.Range("g2:g" & lr1).Copy wb.Worksheets(1).Range("g2")

اخي الكريم ضع نمودج لما تريد بالظبط ساعد الاخرينن ليفهم الجميع قصدك حاول رفع ملف اخر فيه نتيجة متوقعة بعد الترحيل من الرئيسية الى ؟؟؟؟؟ ......

Sub tous_COD() Generate_Test Q_Rand End Sub

فك الضغط وخزن المجلد في اي فولدر documen.rar

جرب هذا العمل الكود يبحث في جميع الصفحات الا صفحة التقرير 2020 الحسابات (1).xlsm

جزاك الله خيرا

ويمكنك استخدام الكود في حدث الشيت Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("a2:l2")) Is Nothing Then If Not IsNumeric(Target.Value) And Target.Value <> vbNullString Then Target.Interior.Color = xlNone GoTo 1 End If '================= If Target >= 100 Then Target.Interior.Color = 255 End If '================== If Target < 100 Then Target.Interior.Color = 5296274 End If End If 1: End Sub

بعد ادنكم ربما تقصد هذا الشيء Classeur1.xlsx