محمد هشام.

جرب =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

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب الصيغة التالية =IFERROR(IF(B8<>"";INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8)/(price_list!$A$5:$A$10000<=$B$4)));"");"") اخر سعر =INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8))) اكبر سعر =MAX(IF(price_list!$A$5:$A$10000<=$B$4;IF(price_list!$E$5:$E$10000=B8;price_list!$J$5:$J$10000))) price list officena - 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد المحترم @محمد حسن المحمد تفضل جرب اخي Sub Total_amount() Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"): Set Dest = Sheets("التجميع بدون تكرار") a = WS.Range("B1").CurrentRegion.Value Dim c() ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2)) Cpt = 1 Set mondico = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For i = 1 To UBound(a) temp = a(i, 1) & a(i, 2) If Not mondico.exists(temp) Then mondico.Add temp, "" For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k c(Cpt, k) = c(Cpt, k) + a(i, k) Cpt = Cpt + 1 Else j = Application.Match(temp, mondico.keys, 0) col = UBound(a, 2) c(j, col) = c(j, col) + a(i, col) End If Dest.[B1:D1000] = Empty Next Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c End Sub كود تجميع .xlsb

بما انك لم تقم بارفاق الملف لنتمكن من تحديد النطاق المرغوب نسخه اليك مثال للمطلوب يمكنك تعديله بما يناسبك Sub Copy_My_Data() Dim Cpt&, lCol&, lRow& Dim WSdata As Worksheet, Dest As Worksheet, MyRng As Range, r As String Dim WS1 As Workbook, WS2 As Workbook :Set WS1 = ThisWorkbook With Application .ScreenUpdating = False r = InputBox("قم بإدخال اسم المصنف المرغوب جلب البيانات منه", "Choose file name") On Error Resume Next If r = False And r <> 0 Then Exit Sub If r = 0 Then Set WS2 = Workbooks("transactionTable.xls") 'اول نسخة من المصنف = 0 Else Set WS2 = Workbooks("transactionTable" & " (" & r & ")" & ".xls") ' تعريف المصنف من خلال الرقم End If If Not WS2 Is Nothing Then Set WSdata = WS2.Sheets("Sheet1") ' transactionTable اسم الشيت المنسوخ منه lRow = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' قم بتعديل النطاق المنسوخ بما يناسبك Set MyRng = WSdata. _ Range("A2", WSdata.Cells(lRow, lCol)) Set Dest = WS1.Sheets("Sheet1") ' b2024' اسم شيت اللصق على ملف Cpt = Dest.Cells(Dest.Rows.Count, "A").End(xlUp).Offset(1).Row MyRng.Copy Dest.Range("A" & Cpt).PasteSpecial Paste:=xlPasteValues Application.Goto Dest.[A1], True .CutCopyMode = False .ScreenUpdating = True MsgBox _ "تم نسخ البيانات بنجاح من" & Chr(10) & Chr(10) & WS2.Name, vbInformation Else MsgBox (" لم يتم العثور على المصنف ") & r, 48, "خطأ" On Error GoTo 0 End If End With End Sub بالتوفيق...... test 2.rar

1) أخي هذا موضوع لا علاقة له بالسؤال المرفق في اول مشاركة. 2) حاول إرفاق نسخة من الملفين معا مع تحديد طريقة النسخ المتوقعة. والنطاق المطلوب ترحيله .وان شاء الله سوف نحاول مساعدتك.

قم باستبدال If TblInv(i, 1) = CB_Pièce Then الى If TblInv(i, 1) = CB_Pièce.Text Then

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار ما يناسبك Sub TEST1() Dim arr(1 To 3) As String ' المسار الافتراضي للمصنف المفتوح arr(1) = ThisWorkbook.path & "\" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(3) = Dir(arr(1) & "transactionTable" & " (" & arr(2) & ")" & ".xls*") If arr(3) <> "" Then Set Clé = Workbooks.Open(arr(1) & arr(3)) Else MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal End If End Sub '************** ' تنشيط ورقة عمل على نفس المصنف Sub test2() Dim shname As String, x_Name As String Do Until WorksheetExists(x_Name) shname = InputBox("Type in the name of the Sheet you want to Activate") x_Name = "transactionTable" & " (" & shname & ")" If Not WorksheetExists(x_Name) Then MsgBox x_Name & " Doesn't exist!", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal: Exit Sub Loop Sheets(x_Name).Activate End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function '****************** Sub test3() Dim arr(1 To 3) As String, file_name As String ' قم بتحديد المسار الخاص بك arr(1) = "C:\Users\hicham\OneDrive\Bureau\test" arr(2) = InputBox("Type in the name of the file you want to open", "Choose file name") file_name = "transactionTable" & " (" & arr(2) & ")" arr(3) = arr(1) & "\" & file_name & ".xls" If Dir(arr(3)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Workbooks.Open filename:=arr(3) End Sub '**************************بطرق اخرى ********************* Sub test4() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Not Dir(arr(2), vbDirectory) = vbNullString Then Set WS = Workbooks.Open(arr(2)) Else MsgBox arr(2) & Chr(10) & "Workbook Not Found", 48, "Not Found" End If End Sub '***************** Sub test5() Dim arr(1 To 2) As String, WS As Workbook arr(1) = InputBox("Type in the name of the file you want to open", "Choose file name") arr(2) = ThisWorkbook.path & Application.PathSeparator & "transactionTable" & " (" & arr(1) & ")" & ".xls" If Dir(arr(2)) = "" Then MsgBox ("Workbook Not Found"), vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal Exit Sub End If Set WS = Workbooks.Open(arr(2)) End Sub test.rar

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

اخي ربما يتعين عليك وضع حماية لورقة العمل لديك لمنع اظهار الاعمدة او اخفائها بدون ادخال كلمة المرور جرب هدا الملف باسوورد 1234 إخفاء اعمدة وصفوف برقم سري.xlsb

Public Property Get WS() As Worksheet: Set WS = Feuil1 End Property Sub Hide_Columns() col = "F:G" On Error Resume Next WS.Columns(col).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Columns(col).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Columns(col).Hidden = True On Error GoTo 0 End If End If End Sub '************************** Sub Hide_Rows() Xrows = "13:14" On Error Resume Next WS.Rows(Xrows).Hidden = True msg = InputBox("أدخل كلمة المرور", "كلمة المرور") If msg = "1234" Then WS.Rows(Xrows).Hidden = False Else If MsgBox("كلمة المرور غير صحيحة، حاول مرة أخرى", Yes Or No, "كلمة مرور خاطئة") = Yes Then WS.Rows(Xrows).Hidden = True On Error GoTo 0 End If End If End Sub إخفاء اعمدة وصفوف برقم سري.xlsb

مرحبا اساتذتنا الكرام يسرني المشاركة معكم في ايجاد حل للمطلوب رغم انني لم استوعب الفكرة جيدا وكنت قد صرفت النظر عن المشاركة في الموضوع لاكن بعد معاينة النتيجة المستخرجة على ملف الاستاد @AbuuAhmed الدي نكن له كل الاحترام والتقدير. اليك اخي هده المساهمة البسيطة على قدر ما استطعت فهمه لحد الساعة مع تغيير اسم الورقة المظافة من مصفوفة الى Test 🫣🫣 Sub test1() Dim wb As Workbook, WSdata As Worksheet, dest As Worksheet, lRow As Long, lCol As Long Set wb = ThisWorkbook: Set WSdata = wb.Sheets("الفواتير"): Set dest = wb.Sheets("Test") A = WSdata.Range("A2:I" & WSdata.[D65000].End(xlUp).Row) With Application .ScreenUpdating = False With dest Intersect(.Range(.Rows(2), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("A:I")).ClearContents End With Dim c(): ReDim c(1 To UBound(A, 1), 1 To 9) Cpt = 0 Set mondico = CreateObject("Scripting.Dictionary") For I = 1 To UBound(A) On Error Resume Next clé = A(I, 4) & A(I, 8) If Not mondico.exists(clé) Then Cpt = Cpt + 1: mondico.Add clé, Cpt: c(Cpt, 1) = clé: F = Cpt Else F = mondico.Item(clé) End If c(F, 1) = A(I, 1): c(F, 2) = A(I, 2): c(F, 3) = A(I, 3): c(F, 4) = A(I, 4): c(F, 5) = c(F, 5) + A(I, 5) c(F, 6) = c(F, 6) + A(I, 6): c(F, 7) = c(F, 7) + A(I, 7): c(F, 8) = A(I, 8): c(F, 9) = A(I, 9) Next dest.[a3].Resize(mondico.Count, UBound(c, 2)) = c lRow = dest.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With dest Union(dest.Range("A3:A" & lRow), dest.Range("F3:F" & lRow)).NumberFormat = "#,##0;- #,##0;""-""??" dest.Range("C3:C" & lRow).NumberFormat = "dddd dd-mm-yyyy" dest.Range("E3:E" & lRow).NumberFormat = "#,##0.0;- #,##0.0;""-""??" If dest.ListObjects.Count <> 0 Then Exit Sub lCol = .Cells(3, dest.Columns.Count).End(xlToLeft).Column dest.ListObjects.Add(xlSrcRange, .Range(dest.Cells(3, 1), .Cells(lRow, lCol)), , xlYes).Name = "Table1" .ListObjects("Table1").ShowAutoFilterDropDown = False End With On Error GoTo 0 .ScreenUpdating = True End With End Sub تجربة1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته لاظافة صور جديدة او استبدالها يجب عليك اتباع الخطوات التالية 1) اظهار الصور المخفية بواسطة الكود المرفق مع الملف 2) اعادة تسمية الصور على حسب احتياجاتك وقد تم شرح الطريقة في الرابط التالي https://streamable.com/ghw7yy اما بخصوص اخر سؤال المعادلة الموجودة في الخلية F3 =IF(D3="";"";VLOOKUP(D3;range1;3;0)) تقوم فقط بجلب اسم الصورة من شيت 2 العمود D المقابلة لقيمة الخلية D3 ورقة 1 ليس بتحويل الصورة الى نص وفي حدث ورقة 1 الكود التالي يقوم باخفاء جميع الصور والبقاء على الصورة الهدف بشرط قيمة الخلية F3 Private Sub Worksheet_Calculate() Dim oPic As Picture Me.Pictures.Visible = False With Range("F3") For Each oPic In Me.Pictures If oPic.Name = .Text Then oPic.Visible = True oPic.Top = .Top oPic.Left = .Left Exit For End If Next oPic End With End Sub البيانات مع الصورة 2.xls

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصد Sub test() Dim i As Long, lRow As Long lRow = Cells(Rows.Count, "A").End(xlUp).Row With Application .ScreenUpdating = False For i = lRow To 2 Step -1 If IsError(.Match(0, Range("A" & i & ":D" & i), 0)) Then Rows(i).EntireRow.Delete End If Next .ScreenUpdating = True End With End Sub ملف.xlsb

ملاحظة : في حالة قمت بحدف عناوين الاعمدة سيتم نسخ البانات بعد اخر خلية فارغة في عمود C ولتثبيت اللصق في الصف 22 ما عليك هو تعديل الصفوف التالية For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) If dest.[C22] = Empty Then dest.[C22].Resize(1, 28).Value = Rng.Value Else: dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If End If ''''''''''''''''''''''''''''''او'''''''''''''''''''''''''''' Dim dlr As Long For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then dlr = dest.Cells(Rows.Count, "C").End(xlUp).Row If dlr < 21 Then dlr = 21 Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Range("C" & dlr).Offset(1).Resize(1, 28).Value = Rng.Value End If Next j

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim wb As Workbook, WS As Worksheet, dest As Worksheet Set wb = ThisWorkbook: Set WS = wb.Sheets("Sheet1"): Set dest = wb.Sheets("Sheet2") Dim j&, col&, ligne&, r As String Dim Rng As Range: col = 12: r = dest.[B19] ligne = WS.Cells(Rows.Count, col).End(xlUp).Row With Application .ScreenUpdating = False dest.Range("C22", Range("AD" & Rows.Count).End(4)).ClearContents For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If Next j If Application.WorksheetFunction.CountA(dest.Range("C22:AD22")) = 0 Then MsgBox "غير موجود" & " / " & r, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True End With End Sub تجربة 2.rar

تمام لاستخراج الرموز بدون تكرار في ورقة ادخال البيانات الخلية P18 ضع المعادلة التالية مع سحبها للاسفل =IFERROR(INDEX($L$18:$L$200; MATCH(0; IF(ISBLANK($L$18:$L$200); 1; COUNTIF(P17:$P$17; $L$18:$L$200)); 0));"") مع تسمية النطاق بالشكل التالي وليكن مثلا Clé =OFFSET('ادخال البيانات'!$P$18;0;0;COUNT(IF('ادخال البيانات'!$P$18:$P$10000="";"";1));1) ولجلب البيانات استخدم الكود التالي Sub Search() Dim WSdata As Worksheet: Dim WSEntry As Worksheet: Set WSdata = Feuil1: Set WSEntry = Feuil2 Dim Clé As String, all As String, lr As Long, F&, Col& Dim a As Range, b As Range, rngCell As Range With Application .ScreenUpdating = False .Calculation = xlCalculationManual lr = WSdata.Cells(WSdata.Rows.Count, "C").End(xlUp).Row Clé = WSEntry.[G1]: all = "الكل" WSEntry.Range("A4:F500").ClearContents For Col = 4 To lr If WSdata.Cells(Col, "H") Like Clé Then Set a = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = a.Value End If If Clé Like all Then Set b = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = b.Value End If Next Col F = WSEntry.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSEntry.Range("A4 :H" & F) WSEntry.Range("A4:H500").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSEntry.Range("A4:H5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية" & " / " & Clé, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub وفي حدث ورقة ادخال البيانات Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("G1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call Search Application.EnableEvents = True End If On Error GoTo 0 End Sub ترحيل بيانات 7.xlsm

مع بعض التعديلات البسيطة Sub Find_And_copy() ' to Update 06 / 01 / 2024 Dim c As Range: Dim Col As Range Dim r As Range: Dim Rng As Range Dim WS As String: Dim j As Long Dim lastrow As Long: Dim MyData As Worksheet: Set MyData = Feuil2 On Error Resume Next If MyData.[H2] = "" Then: MsgBox "المرجوا إدخال تاريخ الغياب", vbInformation, "admin": Exit Sub lastrow = MyData.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If WorksheetFunction.CountA(MyData.Range("G4:G" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [G3], vbExclamation: Exit Sub If WorksheetFunction.CountA(MyData.Range("H4:H" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [H3], vbExclamation: Exit Sub For j = 4 To lastrow If MyData.Range("G" & j) <> "" Then: WS = MyData.Cells(j, "G") Set MyDest = Worksheets(WS) With Application .ScreenUpdating = False With MyDest For Each r In MyDest.Range("A5", .Cells(Rows.Count, 1).End(xlUp)) Set Rng = MyData.Range("A:A").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then For Each c In Application.Intersect(MyData.UsedRange, MyData.[H2]) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set Col = MyDest.Rows(3).Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) If Col Is Nothing Then: MsgBox "المرجوا التحقق من تاريخ الإدخال" & " : " & MyData.[H2].Value, vbInformation, "تعليمات": Exit Sub If Not Col Is Nothing And Rng.Offset(, 6).Value = MyDest.Name Then MyDest.Cells(r.Row, Col.Column).Value = Rng.Offset(, 7).Value End If End If Next c End If Next End With .ScreenUpdating = True End With Next j On Error GoTo 0 MyData.Range("G4:H" & lastrow + 1).ClearContents: [H2] = Empty MsgBox "تم ترحيل البيانات بنجاح ", vbInformation, "admin" End Sub ترحيل بيانات 6.xlsm

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