حسين مامون

ادخل رقم البحث في textbox1 واضغط مفتاح Entr على لوحة المفاتيح testefile.xlsm

عليكم السلام بدون مرفق يصعب فهم الكلام جرب المرفق Book1.xlsm

المرفق بحث في نفس الملف في كل الصفحات وترحيل الى شيت.xlsm

نمودج قريب للشرح في مشاركتك اتمنى ان يساعدك في طلبك m2000.xlsm

ربما يكون المطلوب Sub creatB() Dim OBJECTfso Dim OBJECTfolder Dim OBJECTfils Dim ws As Worksheet Set ws = ActiveSheet ws.Range("a2:a100").ClearContents Set OBJECTfso = CreateObject("scripting.filesystemobject") Set OBJECTfolder = OBJECTfso.getfolder("C:\Users\pc\Desktop\med") ws.Cells(1, "a").Value = "the file founf in " & OBJECTfolder.Name & "Are" For Each OBJECTfils In OBJECTfolder.Files ws.Range("a" & Rows.Count).End(xlUp).Offset(1) = OBJECTfils.Name 1: Next Set OBJECTfolder = Nothing Set OBJECTfils = Nothing Set OBJECTfso = Nothing End Sub

انظر وضعت نتيجة متوقعة في صفحة الارقام ادا كان هذا ما تريد فيكفي انشاء ماكرو نسخ ولصق النتيجة التي وضعتها كمثال هي نقل ارقام جديدة الى ارقام قديمة صفحة الارقام ثم نقل القيم من صفحة قيود الى صفحة الارقام في عمود ارقام جديدة بحث واستبدال متكرر (2).xlsx

الاستاد عاطف ارى انك لم تبدي اي رأي حول مشاركة الاستاد محي الدين ابو البشر حاول شرح اكثر لما تريد ضع النتيجة المتوقعة في عمودين اضافيين اخرين في الصفحة الاولى والثانية

جرب هذا الماكرو ربما يفي بالغرض Set ws = Sheets("الهدف") Dim lr, lr2, X Dim CH As Range Set CH = ws.Range("o2") Dim SH As Worksheet lr2 = 11 Application.ScreenUpdating = False ws.Range("c11:e11").ClearContents For Each SH In Sheets If SH.Name = "الهدف" Then GoTo 1 lr = SH.Range("c" & Rows.Count).End(xlUp).Row For X = 5 To lr If CH = SH.Cells(X, "c") Then ws.[d5] = SH.Name ws.[c7] = SH.Cells(X, "b") ws.Range("c" & lr2).Value = SH.Cells(X, "a").Value ws.Range("d" & lr2).Resize(1, 2).Value = SH.Cells(X, "c").Resize(1, 2).Value lr2 = lr2 + 1 End If Next X 1: Next SH Application.ScreenUpdating = True End Sub

اخي الكريم بدون رفع الملف او الكود المعني لايمكن لاحد التخمين وتقديم المساعدة

عليكم السلام كما قلت لك ستحصل مشاكل اخرى واخرى واخرى حاول تغيير السطر الذي فيه خطأ الى Activeworkbook.sheets set sh = activeworkbook.sheets("sheet1") ثم الثاني

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

اخي الكريم طبيعي ان يعمل الكود خطا ادا غيرنا اسمه او مساره يمكنك تغيير اسم الملف ولكن يجب تغييره ايضا في الكود تحياتي او تغيير الاسطر الاولى في الكود الى ما يلي ولك فيحالة التعامل مع اكثر من ملف ستكون مشاكل Dim ws As Worksheet Set ws = ActiveWorkbook.Sheets("invoice") Dim wss As Worksheet Set wss = ActiveWorkbook.Sheets("sheet1")

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

بعد اذن الاستاذMohamed_Fouad واثراء للموضوع جرب المرفق Bank Cheque.xlsm

Private Sub CommandButton1_Click() Dim ws As Worksheet Set ws = Workbooks("فاتورة").Sheets("invoice") Dim wss As Worksheet Set wss = Workbooks("فاتورة").Sheets("sheet1") 'Dim ws As Worksheet 'Set ws = wx.Sheets("invoice") 'Dim wss As Worksheet 'Set wss = wx.Sheets("sheet1") Dim DT Dim Nam Dim lr As Long Application.ScreenUpdating = False Application.EnableEvents = False lr = wss.Range("a" & Rows.Count).End(xlUp).row + 1 DT = ws.Range("e5") & Format(Now(), "dd-mm-yyyy hh mm ss") With ws ' .Copy ' .UsedRange = .UsedRange.Value Application.DisplayAlerts = False ' Nam = "d:\back\backup\فاتورة" & DT & ".xlsx" Nam = .Range("e5") & " " & Format(Now(), "dd mm yyyy hh mm ss") ThisWorkbook.SaveCopyAs Filename:="D:\back\Backup\" & Nam & ".xlsm" ' ActiveWorkbook.SaveAs Nam, FileFormat:=xlOpenXMLWorkbook '========================================= If ws.[f5].Text = "اجل" Then wss.Range("a" & lr).Value = Nam wss.Range("a" & lr).Font.Color = 255 wss.Range("b" & lr).Value = "اجل" Else: wss.Range("a" & lr).Value = Nam wss.Range("b" & lr).Value = "نقدي" End If '======================================== ' ActiveWorkbook.Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "تم حفظ نسخة باسم " & DT & " ", vbInformation End Sub

عدل كما في الصورة

لم تقم يتغيير السطور كما يجب عموما ارفع الكود كما هو لتعديله

عليكم السلام استاذ محمد عبد السلام غير السطور التالية الى ما يلي وجرب Private Sub CommandButton1_Click() ' saveas_facture() 'Dim wx As Workbook 'Set wx = Workbooks("ÝÇÊæÑÉ") Dim ws As Worksheet Set ws = Workbooks("فاتورة").Sheets("invoice") Dim wss As Worksheet Set wss = Workbooks("فاتورة").Sheets("sheet1")

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

ربما الاستاذ فوزي يقصد بالفورم الصورة التالية لان الكود يحذفها اذا اكان ذلك هو المقصود فالجزء المحاط بالاحمر في الصورة التالية هو المسؤول عن ذلك قم بحدفه وجرب

تم تعديل الكود جرب ربما يكون ما تريد Sub trheel() Dim cl As Range, i As Integer For i = 2 To 41 For Each cl In Range("G3:G" & [G10000].End(xlUp).Row) If cl.Value = Sheets(i).Name Then If cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF Then GoTo 1 cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1) cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF End If 1: Next Next End Sub

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

اليك هذا الماكرو جربه لعله ما تريد Sub test3() Dim rng Dim c, r, x Application.ScreenUpdating = False Set rng = Range("c2") r = 5 x = 0 For c = 5 To 1000 If rng = 0 Or rng = "" Then Range("c2") = "": Exit Sub Range("a" & r) = 1 + x x = Range("a" & r) + 1 - 1 r = r + 1 rng = rng - 1 Next Application.ScreenUpdating = True End Sub

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

تفضل اظهار البيانات من اليست بوكس الى التكست بوكس.xlsm