حسين مامون

جرب المرفق حركات.xlsm

وعليكم السلام ربما تقصد هكذا في المرفق عند تفعيل الفورم تختفي textbox1 و textfind ولما تختار نوع البحث تظهر حسب الاختيار اتمنى ان يكون ما تقصد فاتورة(2).xlsm

بعد رفع الملف فك الضغط واحفظ المجلد في اي فولدر ثم جربه myDOS.rar

وهنا تم اضافة كود استعلام بين تاريخين Sub Renseignements() Dim ws As Worksheet Dim sh As Worksheet Dim rng1, rng2 As Date Dim lr1, lr2 As Long Dim x As Long Set ws = Sheets("TAKRIR") rng1 = ws.[c2]: rng2 = ws.[d2] Application.ScreenUpdating = False lr1 = ws.Cells(Rows.Count, 1).End(3).Row + 1 ws.Range("a5:m" & lr1).ClearContents For Each sh In Sheets If sh.Name <> "Tarheel" And sh.Name <> "TAKRIR" Then lr2 = sh.Cells(Rows.Count, 1).End(3).Row For x = 3 To lr2 lr1 = ws.Range("a" & Rows.Count).End(xlUp).Row + 1 Select Case sh.Cells(x, 1).Value2: Case rng1 To rng2 ws.Range("a" & lr1).Value = sh.Name ws.Range("a" & lr1).Offset(, 1).Resize(1, 14).Value = sh.Cells(x, "b").Resize(1, 14).Value End Select Next x End If Next sh Application.ScreenUpdating = True End Sub ترحيل مدين ودائن.xlsb

السلام عليكم ملاحظة تم تعديل الجدول في الصفحات هذا الكود للترحيل معمول بالحلقات التكرارية ولكن فعاليته جيدة واتمنى ان يفي بالغرض Sub envoier() Dim ws As Worksheet Dim sh As Worksheet Dim rng1, rng2 As Range Dim lr1, lr2 As Long Dim x, x2, S As Long Set ws = Sheets("Tarheel") Set rng1 = ws.[e1]: Set rng2 = ws.[f1] Application.ScreenUpdating = False lr1 = ws.Cells(Rows.Count, 4).End(3).Row If lr1 = 2 Then Exit Sub For S = 3 To lr1 For Each sh In Sheets If sh.Name <> "Tarheel" And sh.Name <> "TAKRIR" Then If ws.Cells(S, 4) = sh.Name Then For x = 4 To 15 If sh.Cells(1, x) = rng1 Then lr2 = sh.Cells(Rows.Count, 1).End(3).Row + 1 ' sh.Activate sh.Range("a" & lr2).Resize(, 2).Value = ws.Range("a2").Resize(, 2).Value sh.Range("c" & lr2).Value = ws.Cells(S, "c").Value sh.Range("a" & lr2).Offset(, x - 1).Resize(, 2).Value = _ ws.Cells(S, "e").Resize(, 2).Value End If Next x End If End If Next sh Next S If MsgBox("هل تريد افراغ البيانات في الشيت", vbExclamation + vbYesNo) = vbYes Then ws.Range("c3:f" & lr1).Select End If Application.ScreenUpdating = True End Sub ترحيل مدين ودائن.xlsb

الحل في مشاركتي الاخيرة انسخ الكود الى ملفك

Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim lr, x lr = Cells(Rows.Count, 1).End(3).Row If Not Intersect(Target, Range("a4:a" & lr)) Is Nothing Then For x = 4 To lr Cells(x, "d") = Cells(x, "a") & Format(Range("c2"), "mmyyyy") & "PS" Next x End If End Sub 01.xlsm

01.xlsm

استعمل هذا الكود Sub test() Dim lr, x lr = Cells(Rows.Count, 1).End(3).Row For x = 4 To lr Cells(x, "d") = Cells(x, "a") & Format(Range("c2"), "mmyyyy") & "PS" Next x End Sub 01.xlsm

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

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

Sub test() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lr, x Dim rng Set ws1 = Sheets(1) Set ws2 = Sheets(2) Set rng = ws2.Range("c3") lr = ws1.Cells(Rows.Count, 2).End(3).Row For x = 2 To lr If ws1.Cells(x, 2) = rng Then ws1.Cells(x, 1).Resize(1, 4).Copy ws2.Range("b7").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Application.CutCopyMode = False Exit For End If Next x End Sub جرب المرفق test (2).xlsm

بعد ادن الاستاد خيماوي كووول جرب المرفق ادخل رقم الشيت في العمود B ثم عدد مرات النسخ الى جانبه بالعمود A ثم انقر زر Entre لوحة المفاتيح كود عادي في حدث change اتمنى ان يفي بالغرض 1.xlsm

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

تفضل نموذج اكسيل لشيت اضافة.xlsm

ما فهمت في طلبك لو تقصد طباعة اي عدد من صفحة واحدة كل نسخة تحمل رقم فجرب المرفق Sub printTOUS() Dim x Dim printx printx = InputBox("ادخل اي عدد النسخ التي تريد طباعته") If printx = "" Then Exit Sub For x = 1 To printx Range("L6") = x Range("A1:L23").printOUT Next x Range("L6") = "" End Sub نموذج اكسيل لشيت اضافة.xlsm

اين الصفوف الفارغة في ملفك ؟ هل ممكن توضيح اكثر

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

في المرة القادمة ارفع ملف مع شرح ما تريد بالتفصيل استعمل الكود التالي اذا كانت البيانات في العمود A Sub TEST() Dim LR LR = Cells(Rows.Count, 1).End(3).Row If LR = 1 Then Exit Sub Range("a1:a" & LR).RemoveDuplicates Columns:=1, Header:=xlNo End Sub اليك الرابط التالي ربما تستفيد من مشاركات الاساتذة الافاضل

امسح الجزء المحاط بالاحمر وانسخ الى مكانه هذا الجزء TextBox2 = "": TextBox3 = "": ComboBox6 = "": TextBox5 = "": TextBox6 = "": _ ComboBox2 = "": ComboBox3 = "": ComboBox4 = "": TextBox5 = "": ComboBox5 = "": _ TextBox10 = "": TextBox11 = "":

اخي الكريم اولا:لديك ادوات الفورم مخطلطة بين التيكست بوكسات والكومبوبوكسات ولتعمل الاكواد لابد من التعديل ثانيا : هناك حلقة تكرارية خاصة لافراغ واخرى لترحيل وتجدها هكذا for c = 1 to 12 وتعني التيكتبوكسات وهنا يكمن المشكل عندك ، لان تيكست بوس12 مخصص للبحث ولا يمنكن ادخاله في الحلقة التكرارية الحلقة التكرارية تحسب من 1 الى 12 من التيكسبوكسات ، ادا اين باقي التيكسبوكسات رقم 4 و 7 و 8 و 9 في الفورم لهذا قمت بتعديل محتويات الفورم الكومبوبوكس الاول غيرت اسمه الى textbox4 والتالي الى textbox7 و هكذا اما textbox12 غيرته الى textbox13 عموما جرب في المرفق لم اقم باي تعديل في محتويات الفورم فقط الاكواد المكتبه 1 (2)22.xlsm

جرب المرفق انظر التجربة بالصور عندي المكتبه 1 (2).xlsm

جرب المرفق المكتبه 1 (2).xlsm

جرب المرفق نهائى شهدات محمد.xls

هكذا مثلا تختار من الكومبوبوكس وتضغط زر اظهار الشيت الذي تختاره انت