محمد هشام.

ادن جرب هدا ووافينا بالنتيجة Sub Compare_Col() Dim lr As Long, i As Long Dim WS As Worksheet: Set WS = Worksheets("Sheet1") On Error Resume Next lr = WS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 1 To lr Application.ScreenUpdating = False If WorksheetFunction.CountIf(Range("C1:C" & lr), Range("A" & i)) < 1 Then Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = Range("A" & i).Value End If Next i Application.ScreenUpdating = True End Sub marem v2.xlsb

الطريقة الصحيحة هي استخراج الاسماء بعد مقارنة الأعمدة في عمود مغاير لاكن بما انك تريد استخراج النتائج تحت آخر خلية بها بيانات ربما يتطلب منك ذالك استخدام الأكواد.

Sub test1() Dim Cpt As Range, Rng As Range Application.ScreenUpdating = False Irows = "12:34" Set Cpt = Range("A12:A" & Cells(Rows.Count, "A").End(xlUp).Row) For Each Rng In Cpt If Rng.Value = "0" Then Rng.EntireRow.Hidden = True Next Rng ActiveWindow.SelectedSheets.PrintOut Copies:=1 Rows(Irows).Hidden = False Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub test2() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 12: LastRow = 34 Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False For i = LastRow To StartRow Step -1 If Cells(i, "A") = "0" Then Rows(i).Hidden = True Next i ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False Application.ScreenUpdating = True End Sub البرنامج.xlsm في حالة الرغبة بتسلسل عمود (م) على حسب البيانات الموجودة أثناء الطباعة قم بإستبدال المعادلة الخاصة بك بالصيغة التالية مع سحبها للأسفل الخلية (B12) =IF(D12>0;SUBTOTAL(103;$D12:D$12);"")

من المفروض ارفاق الملف في اول مرة بنفس تنسيق الملف الاصلي اخي سعد هناك بعض الاخطاء البسيطة على ملفك تسببت في عدم تنفيد الكود بالشكل الصحيح 1) عدم تطابق الاسماء في رؤوس اعمدة المواد والقائمة المنسدلة 2) لم تقم بتغيير عمود لصق البيانات ليتوافق مع الشكل الجديد ' لصق بعد اخر خلية من عمود (AG) desWS.Cells(Rows.Count, 33).End(xlUp).Offset(1).PasteSpecial xlPasteValues Or desWS.Cells(desWS.Rows.Count, "AG").End(xlUp).Offset(1).PasteSpecial xlPasteValues مع تفريغه في اول الكود بالشكل التالي لكي لا يتم نسخ البيانات تحت بعضها البعض desWS.Range("AG13:AG" & Rows.Count).ClearContents وفي حدث ورقة saad Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Select Case Target.Address(0, 0) Case "Y7": Call CopyData2: Case "AF8": Call CopyData2 Target.Select Case Else: Exit Sub End Select End Sub eman v2.xlsm

Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar

Sub Test() Dim lr As Long, r As Range Dim ws As Worksheet: Set ws = Worksheets("واجهة") Dim Wdst As Worksheet: Set Wdst = Worksheets("مبيعات") Const Check = "A13:C13": Set r = ws.Range(Check): Rng = ws.[A3:AA13].Value lr = Wdst.Cells(Rows.Count, 3).End(xlUp).Row + 1 If Application.WorksheetFunction.CountA(r) < r.Count Then MsgBox "برجاء اكمال البيانات", vbExclamation, "كود الترحيل " Exit Sub Else Wdst.Range("A" & lr).Resize(UBound(Rng), UBound(Rng, 2)).Value2 = Rng ws.[A13:AA13] = Empty MsgBox "تم بنجاح", vbInformation, "كود الترحيل " End If End Sub ترحيل1 V1.xlsm

مجهود تشكر عليه استاذ احمد محاولة بطريقة اخرى ربما تتضح الفكرة في انتظار التوضيح اكثر من صاحب الملف =(INDEX('رئيسي '!B:B,MAX(('رئيسي '!$A$2:$A$100="كرتونة صنف "&$A$1)*ROW($A$2:$A$100)*('رئيسي '!$B$2:$B$100<>""))))-(INDEX(B:B,MAX(($C$2:$C$100=$A$1)*ROW($C$2:$C$100)*($B$2:$B$100<>""))))&" "&"علبة" getBalance 6.xlsm

Public Sub CopyData2() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") ' خلية البداية Col_Star = 10 '(R) عمود الشرط Col_Search = 18 'الشرط الاول(الفصل) Clé1 = desWS.[R12] 'الشرط الثاني (المادة) Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False 'التحقق من وجود قيمة في خلايا الشرط If Len(Clé1) > 0 And Len(Clé2) > 0 Then ' افراغ البيانات السابقة desWS.Range("C14:U" & Rows.Count).ClearContents ' اسماء الاوراق المستهدفة Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSdata = Sheets(Sh(i)) With WSdata ' الغاء الفلترة .AutoFilterMode = False ' Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' النطاق Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow ' في حالة تحقق الشرط الاول If WSdata.Cells(Rng, Col_Search).Value = Clé1 Then 'عمود (C) تحديد اخر صف عليه بيانات rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row ' الاعمدة المرغوب جلب بياناتها Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) ' لصق البيانات بعد اخر قيمة من عمود (C) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSdata.Cells(Rng, Cpt(c)).Value Next c End If Next Rng ' فلترة جميع الاوراق على الشرط الاول rngFound.AutoFilter Field:=16, Criteria1:=Clé1 ' البحث في الصف 9 عن الشرط الثاني (المادة) Set rngSearch = WSdata.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then 'نسخ بيانات العمود rngSearch.Offset(1).Resize(ligne - 1).Copy ' لصق بعد اخر خلية من عمود (U) desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'الغاء الفلترة rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub

حياك الله استاد @AbuuAhmed لقد قمت بتجربة الدالة الخاصة بك فعلا هي تشتغل بشكل جيد لاكن على حسب ما فهمت انا ان الاخ @ضياء 2 طلبه يتمثل في جلب اخر قيمة بشرط الخلية A1 لنفترض انه تم تغيير القيمة الى الثاني مثلا او الثالث واظافة صنف مغاير وليكن كرتونة صنف الثاني يجب جلب اخر قيمة من ورقة الرئيسي مع خصم اخر قيمة من ورقة 1 بشرط القيمة الموجودة في الخلية A1 ونوعية الصنف ربما والله اعلم getBalance_03.xlsm

جرب وضع الصيغة التالية =IFERROR(LOOKUP(2,1/('رئيسي '!$A$2:$A$17="كرتونة صنف "&$A$1),'رئيسي '!$B$2:$B$17)-LOOKUP(2,1/($C$2:$C$20=$A$1),$B$2:$B$20)&" "&"علبة","") ورقة 2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Public Sub CopyData() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") Col_Star = 10: Col_Search = 18: Clé1 = desWS.[R12]: Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False If Len(Clé1) > 0 And Len(Clé2) > 0 Then desWS.Range("C14:U" & Rows.Count).ClearContents Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSData = Sheets(Sh(i)) With WSData .AutoFilterMode = False Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow If WSData.Cells(Rng, Col_Search).Value = Clé1 Then rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSData.Cells(Rng, Cpt(c)).Value Next c End If Next Rng rngFound.AutoFilter Field:=16, Criteria1:=Clé1 Set rngSearch = WSData.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then rngSearch.Offset(1).Resize(ligne - 1).Copy desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub ترحيل الدرجات v2.xlsm

تفضل اخي حاولت قدر الامكان اختصار الكود بطريقة ابسط نوعا ما ليسهل التعامل معه والتعديل عليه للضرورة مع توضيح بعض النقاط المهمة Sub GetPrice3() Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date Dim c As Range, f As Range, a&, XPric As String, Clé As Range Set WSitems = ThisWorkbook.Sheets("items") Set dest = Worksheets("itemout") 'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية XPric = dest.Range("E4"): Set Title = dest.[B8:B32] If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & dest & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else 'تعريف الورقة الهدف Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) End If End If 'التحقق من ادخال كود الصتف If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin" Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False If WSPrice.FilterMode Then WSPrice.ShowAllData ' البحث عن عمود نوع التعامل Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _ LookAt:=xlWhole) If Not Clé Is Nothing Then ' افراغ البيانات السابقة For a = 8 To 32 Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents Next a '******** ' جلب البيانات من القائمة************* ' بشرط كود الصنف عمود 'B' For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp)) 'D' البحث في قائمة الاسعار عمود Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then '7(G)' وضع السعر في عمود dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4 For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row 'items'جلب اسم الصنف من ورقة Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart) If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value Next Key End If Next ' تسلسل عمود 'A' For Each s In Title If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0") Next fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row 'القيمة F*G With dest.Range("H8:H" & fRng) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With ' نسخ اسم قائمة السعر المستخدمة dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name Else MsgBox "نوع التعامل غير موجود" & _ vbCrLf & "", vbExclamation, XPric End If .EnableEvents = True .ScreenUpdating = True End With End Sub وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي تأكد من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار اليك الملف للتجربة price list officena V4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_Sheet() 'انشاء ورقة جديدة وتسميتها وفق التسلسل المطلوب Dim f As Worksheet, Msg As Variant, Data As Worksheet Dim WSname As String, Cpt As String Set Data = Sheets("T1") WSname = "SMS" & Format(Date, "DDMMYY") Msg = MsgBox("انشاء ورقة جديدة؟", vbYesNo, WSname) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next Cpt = Worksheets(WSname).Name If Cpt = "" Then Data.Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) ' اظافة تاريخ واسم اليوم Set f = ActiveSheet f.Name = WSname: f.[E1].Value = Date: f.[C1].Value = Format(Date, "DDDD") '*******للاحتفاظ بالصيغ يمكنك الغاء هدا السطر With f.ListObjects(1).DataBodyRange .Value = .Value End With '********************************************** Else MsgBox "ورقة العمل موجودة مسيقا" & _ "", vbInformation, WSname End If .ScreenUpdating = True .DisplayAlerts = True End With End Sub Sub Save_folder_PDF() 'PDF '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String, Msg As Variant Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next path = ThisWorkbook.path & "\" folderName = "ملفات PDF" MkDir path & folderName Fname = folderName & "\" & WS.Name & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=path & Fname ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName On Error GoTo 0 End Sub Sub Save_folder_Excel() 'Excel '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Application.ActiveWorkbook.SaveAs fileName:=path & Fname & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName End Sub مع اظافة امكانية تنفيد الاكواد بطريقة اخرى ستجدها داخل الملف المرفق بالتوفيق... نمودج V2.xlsb

العفو اخي يسعدنا اننا استطنا مساعدتك ملاحظة في حالة نسخ الكود فقط الى ملفك الاصلي يجب اولا مطابقة بيانات القائمة المنسدلة E4 مع رؤؤس الاعمدة على جميع الاوراق كما في الملف المرفق ليشتغل مع الكود بشكل جيد

تفضل اخي ضع هدا في موديول Sub GetPrice2() Dim WSPrice As Worksheet, dest As Worksheet, ws As Worksheet, WSitems As Worksheet Dim LASTROW&, Dest_Last&, Cpt&, DataRow&, destRow&, I&, derlig&, Z& Dim Clé As Object, dictKey As String, Price_list As String Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range Dim Col As Variant, f As Variant, Réf As Variant Dim ShtDate As Date, MaxDate As Date, Title As Range Dim XPric As Range, XROW As Range, S As Range With Application .EnableEvents = False .ScreenUpdating = False Set dest = Worksheets("itemout") Set WSitems = ThisWorkbook.Sheets("items") Set XPric = dest.[E4]: Set Title = dest.[B8:B32]: Price_list = dest.[B4].Value If Price_list = "" Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub If XPric = "" Then: MsgBox "يجب عليك إدخال نوع التعامل", vbInformation: Exit Sub If Len(Price_list) > 0 Then If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & Price_list & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) With WSPrice If WSPrice.FilterMode Then WSPrice.ShowAllData DataRow = 5 LASTROW = .Range("D" & .Rows.Count).End(xlUp).Row Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(LASTROW, "J")) Col = srcRng.Value2 End With For Z = 8 To 32 Union(dest.Range("A" & Z), dest.Range("C" & Z), dest.Range("G" & Z), dest.Range("H" & Z)).ClearContents Next Z With dest destRow = 8 Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row Set KeyRng = .Range(.Cells(destRow, "B"), .Cells(Dest_Last, "F")) f = KeyRng.Value2: Set Dest_Rng = .Cells(destRow, "G") ReDim Réf(1 To UBound(f, 1), 1 To 1) End With Set Clé = CreateObject("Scripting.dictionary") For I = 1 To UBound(Col) dictKey = Col(I, 1) If Not Clé.exists(dictKey) And (dictKey) <> "" Then Clé(dictKey) = I End If Next I For I = 1 To UBound(f) dictKey = f(I, 1) If Clé.exists(dictKey) Then Cpt = Clé(dictKey) Set XROW = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, LookAt:=xlWhole) If Not XROW Is Nothing Then For Frow = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row Set B = WSitems.Cells.Find(What:=dest.Range("B" & Frow), LookAt:=xlPart) If Not B Is Nothing And B <> "" Then dest.Range("C" & Frow) = B.Offset(0, 1).Value Next Frow Réf(I, 1) = WSPrice.Cells(Cpt + 4, XROW.Column) Else MsgBox "نوع التعامل غير موجود" Exit Sub End If End If On Error Resume Next Next I Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf End If End If End If For Each S In Title If S.Value <> "" Then J = J + 1 S.Offset(0, -1).Value = Format(J, "0") End If Next derlig = dest.Range("B" & dest.Rows.Count).End(xlUp).Row With dest.Range("H8:H" & derlig) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With .EnableEvents = True .ScreenUpdating = True dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name End With End Sub وهدا في حدث ورقة itemout Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("E4")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Application.EnableEvents = False Call GetPrice2 End If If Intersect(Target, Range("B8:B32,F8:F32,H8:H32")) Is Nothing Then Exit Sub Call GetPrice2 Application.EnableEvents = True On Error GoTo 0 End Sub price list officena V3.xlsm

ربما غير واضح ويلزمه بعض التركيز 🤔😁 تفضل اخي جرب واي استفسار او اظافة لا تتردد في دكرها Sub GetPrice() Dim Lastrow&, Dest_Last&, Cpt&, DataRow&, WSDestRow&, i& Dim WSPrice As Worksheet, WSDest As Worksheet, WS As Worksheet Dim Clé As Object, dictKey As String, Price_list As String Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range Dim Col As Variant, f As Variant, Réf As Variant Dim ShtDate As Date, MaxDate As Date With Application .EnableEvents = False .ScreenUpdating = False Set WSDest = Worksheets("itemout"): Price_list = WSDest.[B4].Value If Price_list = vbNullString Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub If Len(Price_list) > 0 Then If IsDate(WSDest.Range("B4").Value) Then For Each WS In Worksheets If IsDate(WS.Name) Then ShtDate = CDate(WS.Name) If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate End If Next WS If MaxDate = 0 Then MsgBox "قائمة الأسعار " & Price_list & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else On Error Resume Next Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) With WSPrice DataRow = 5 Lastrow = .Range("D" & .Rows.Count).End(xlUp).Row Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(Lastrow, "J")) Col = srcRng.Value2 End With With WSDest WSDestRow = 8 Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row Set KeyRng = .Range(.Cells(WSDestRow, "B"), .Cells(Dest_Last, "F")) f = KeyRng.Value2: Set Dest_Rng = .Cells(WSDestRow, "G") WSDest.[G8:G32] = Empty ReDim Réf(1 To UBound(f, 1), 1 To 1) End With Set Clé = CreateObject("Scripting.dictionary") For i = 1 To UBound(Col) dictKey = Col(i, 1) If Not Clé.exists(dictKey) And (dictKey) <> "" Then Clé(dictKey) = i End If Next i For i = 1 To UBound(f) dictKey = f(i, 1) If Clé.exists(dictKey) Then Cpt = Clé(dictKey) Réf(i, 1) = Col(Cpt, 7) End If Next i Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf End If End If End If .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم جلب الأسعار من قائمة" & " " & WSPrice.Name & " " & "بنجاج", _ vbInformation, "التحقق من قوائم الأسعار" End Sub price list officena V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل بالاكواد هل يناسبك Public Property Get ws() As Worksheet: Set ws = Sheet1 End Property Private Sub ComboBox1_GotFocus() Application.ScreenUpdating = False Set d = CreateObject("Scripting.Dictionary") For Each c In ws.Range("O2", ws.Cells(Rows.Count, "O").End(xlUp)) If Not d.Exists(c.Value) Then d(c.Value) = "" Next c MyRng = d.keys Me.ComboBox1.List = MyRng End Sub '******************* Private Sub ComboBox1_Change() Dim i&, lastrow&, r As Range, MyRng As Range lastrow = ws.Columns("A:O").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set MyRng = ws.Range("A2:O" & lastrow - 1): Set Tbl = ws.ListObjects("الجدول93") Clé = ComboBox1 Application.ScreenUpdating = False Tbl.Range.AutoFilter Field:=15, Criteria1:=Clé For i = 2 To lastrow Step 2 Set r = Range("A" & i & ":O" & i) If Cells(i, "O").Value = "الورشة" Then r.Interior.Color = RGB(51, 204, 204) ElseIf Cells(i, "O").Value = "التقنية" Then r.Interior.Color = RGB(255, 204, 153) ElseIf Cells(i, "O").Value = "التأجير" Then r.Interior.Color = RGB(255, 255, 0) Else r.Interior.ColorIndex = xlColorIndexNone End If Next i If Me.ComboBox1 = Empty Then Tbl.ShowAutoFilter = False: MyRng.Interior.ColorIndex = xlColorIndexNone Application.ScreenUpdating = True End Sub نموذج3 .xlsb

جرب Private Sub CmdD_Click() Dim Cpt As Variant, Clé As String, Lr As Long, i As Integer Dim WS As Worksheet: Set WS = Sheets("الصادر") Clé = Me.T3.Value Lr = WS.Cells(Rows.Count, 1).End(xlUp).Row If Clé = Empty Then: MsgBox "قم أولا بإختيار سجل لحذفه", vbExclamation, "حذف": Exit Sub Cpt = MsgBox(" أنت على وشك حذف " & " ( " & Clé & " ) " & " ، هل تريد المواصلة ", vbYesNo, "تأكيد الحذف") If Cpt <> vbYes Then Exit Sub Application.ScreenUpdating = False For i = 3 To Lr If WS.Range("C" & i) = Clé Then WS.Cells(i, 1).Resize(, 10).Delete Shift:=xlUp End If Next Me.Image1.Picture = LoadPicture(none) For x = 1 To 9: Me.Controls("T" & x) = "": Next Application.ScreenUpdating = True MsgBox "تمت عملية الحذف بنجاح" End Sub برنامج الصادر 2024.xlsm

جرب =IF(E6<=F6;F6*IFS(E6<=2000;1%;E6<=5000;2%;E6<=7000;3%;TRUE;5%);"")

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

اعتقد ان الكود الخاص بي يفعل نفس الشيء ينقصه فقط تحديد النطاق المرغوب الاشتغال عليه لعدم دكرك دالك في اول مشاركة يمكنك التحقق من الرابط التالي : https://streamable.com/49qe96 تم تعديل الكود ليتناسب مع طلبك الاخير Sub Find_and_Replace_values() Dim Title As Variant, WS As Worksheet: Set WS = ActiveSheet Dim arr(2) As Variant, WSrng As Range, i As Integer, Cpt As Long Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & " " & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub WSrng.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub في حالة الرغبة بعدم استبدال الصيغ بصفة عامة والتعامل مع القيم فقط يمكنك استخدام هدا الخيار ''''''''''''''' ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub For Each c In WSrng If Not c.HasFormula And c <> "" Then c.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) End If Next c MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub Find_and_Replace_FormulaVersion3.xlsb

العفو اخي يسعدنا اننا استطعنا مساعدتك 😄

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() LastSheet = Sheets.Count Sheets("نمودج").Copy after:=Sheets(LastSheet) End Sub نسخ و اعادة التسمية Sub test2() Dim F As Variant LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) F = InputBox(prompt:="أكتب إسم الورقة الجديد", _ Title:="إعادة تسمية ورقة " & " " & ActiveSheet.Name) ActiveSheet.Name = F End Sub 'قم بتعديله بما يناسبك Sub test3() LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) ActiveSheet.Name = Sheets("TEST").Range("c4").Value End Sub نمودج.xlsb

أظن أن طلبك ليس بالصعب لاكن من الأفضل محاولة إرفاق عينة لشكل البيانات عندك على الملف الأصلي. لنتمكن من فهم طلبك بشكل أوضح. ربما نستطيع مساعدتك.

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخ ايهاب عبد الحميد جرب الكود التالي Sub Find_and_Replace_values_comments() Dim Title As Variant, WS As Worksheet: Set WS = Sheets("Sheet1") Dim arr(2) As Variant, WSrng As Range, i As Integer, cell As Range Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next 'قم بتعديل النطاق بما يناسبك Set WSrng = WS.Range("A1:M100") WSrng.Replace arr(0), arr(1), xlPart, , False For Each cell In WSrng.SpecialCells(xlCellTypeComments) cell.Comment.Text Application.Substitute(cell.Comment.Text, arr(0), arr(1)) Next End Sub في حالة الرغبة في البحث والإستبدال على جميع صفحات المصنف فقد تمت إظافة الكود في الملف المرفق بالتوفيق........... Find_and_Replace_FormulaVersion.xlsb