محمد هشام.

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

آسف أخي غير A4 الى C4 If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub With WS_dest

تفضل اخي بالنسبة للترحيل اليك الكود التالي Sub Transfer() Dim K%, DL2%, S%, Rng As Range Dim WS_data As Worksheet: Set WS_data = ThisWorkbook.Sheets("تسجيل البيعة") Dim WS_dest As Worksheet: Set WS_dest = ThisWorkbook.Sheets("تسجيل المخزون") Application.ScreenUpdating = False K = WS_data.Range("C65500").End(xlUp).Row + 1 If WS_data.Range("C4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub If WS_data.Range("D2") = Empty Then: MsgBox "المرجوا ادخال التاريخ", 64: Exit Sub If WS_data.Range("H2") = Empty Then: MsgBox "المرجوا ادخال رقم الفاتورة", 64: Exit Sub With WS_dest DL2 = WS_dest.Range("C65500").End(xlUp).Row + 1 S = DL2 + K - 4 WS_dest.Range("F" & DL2 & ":F" & S) = WS_data.Range("c4:c" & K).Value WS_dest.Range("G" & DL2 & ":G" & S) = WS_data.Range("D4:D" & K).Value WS_dest.Range("H" & DL2 & ":H" & S) = WS_data.Range("E4:E" & K).Value WS_dest.Range("I" & DL2 & ":I" & S) = WS_data.Range("F4:F" & K).Value WS_dest.Range("C" & DL2 & ":C" & S) = WS_data.Range("D2") WS_dest.Range("D" & DL2 & ":D" & S) = WS_data.Range("H2") WS_dest.Range("E" & DL2 & ":E" & S) = WS_data.Range("J2") End With Set Rng = WS_data.Range("C4:I" & K).SpecialCells(xlCellTypeConstants) Rng.ClearContents Application.ScreenUpdating = True End Sub اما بالنسبة لتصفية البيانات يمكنك استخدام هدا الكود Sub BFVB() Dim lastRow As Long, lrow As Long, Article As Range Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("C2") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("C" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجو ادخال الصنف": Exit Sub On Error Resume Next Set Article = sh2.Range("G:G").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:G" & lrow).ClearContents sh2.Range("G1").AutoFilter Field:=5, Criteria1:="=" & Rng sh2.Range("C1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("C2:I" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh.Activate DL = sh.Range("A65500").End(xlUp).Row DC = sh.Cells(3, Columns.Count).End(xlToLeft).Column sh.Range("A3:G100").Borders.LineStyle = xlNone sh.Range(Cells(3, 1), Cells(DL, DC)).Borders.Weight = xlThin On Error GoTo 0 End With Else m = MsgBox("الصنف " & " " & Rng & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True On Error GoTo 0 End Sub مع وضع هدا الكود في حدث شيت (الشهر) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Address(False, False) = "C2" And Target.Value <> "" Then Call BFVB End If End Sub mywork 6.xlsm

تفضل اخي تم الاعتماد على رقم التسلسل لتعديل البيانات او حدفها بحكم انه هو الوحيد الغير مكرر عندك على الجدول Sub Délete_Client() ' حدف Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, ST As Long Dim msg As VbMsgBoxResult, Client As String Set WS = Worksheets("Orders") Set WS2 = Worksheets("Items") Client = WS2.Range("F4") N_row = WS2.Range("W1") Application.ScreenUpdating = False If Client = Empty Then MsgBox Client & "المرجوا تحديد الصف المراد حدف بياناته", vbExclamation, "إنتباه" Exit Sub End If msg = MsgBox(" هل انت متأكد من حدف : " & Client, vbYesNo + vbQuestion + vbDefaultButton2, "إنتباه") Application.ScreenUpdating = False If msg = vbNo Then Exit Sub End If WS.Activate For i = Cells(Rows.Count, 2).End(xlUp).Row To 7 Step -1 If Cells(i, 2).Value = N_row Then Rows(i).Delete End If Next i For ST = 7 To Cells(Rows.Count, "B").End(xlUp).Row If Cells(ST, "c").Value <> "" Then Cells(ST, "b").Value = ST - 6 End If Next ST WS2.Activate WS2.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,J21,w1") = Empty Application.ScreenUpdating = True m = MsgBox("تم حدف البيانات بنجاح", 64, "تأكيد") End Sub Dynamic Orders - Pivot_V6.xlsm

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

تفضل اخي كود لنقل البيانات من شيت (Ordres) الى شيت (Items) بدوبل كليك على عمود اسم العميل Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) On Error Resume Next Dim lastrow As Long Dim Row_Clt As Worksheet: Set Row_Clt = Worksheets("Items") Dim sh As Worksheet: Set sh = Worksheets("Orders") lastrow = sh.Cells(sh.Rows.Count, "d").End(xlUp).Row Set ws_data = ActiveCell If Intersect(Target, Range("D7:D" & lastrow)) Is Nothing Then Else Application.ScreenUpdating = False Row_Clt.Range("F4") = ws_data.Value Row_Clt.Range("F6") = ws_data.Offset(0, 1).Value Row_Clt.Range("H6") = ws_data.Offset(0, 2).Value Row_Clt.Range("F9") = ws_data.Offset(0, 3).Value Row_Clt.Range("H9") = ws_data.Offset(0, 4).Value Row_Clt.Range("J9") = ws_data.Offset(0, 5).Value Row_Clt.Range("F13") = ws_data.Offset(0, 6).Value Row_Clt.Range("H13") = ws_data.Offset(0, 7).Value Row_Clt.Range("J13") = ws_data.Offset(0, 8).Value Row_Clt.Range("F15") = ws_data.Offset(0, 9).Value Row_Clt.Range("H15") = ws_data.Offset(0, -1).Value Row_Clt.Range("J15") = ws_data.Offset(0, 10).Value Row_Clt.Range("F18") = ws_data.Offset(0, 11).Value Row_Clt.Range("H18") = ws_data.Offset(0, 12).Value Row_Clt.Range("F20") = ws_data.Offset(0, 14).Value Row_Clt.Range("H20") = ws_data.Offset(0, 15).Value End If On Error GoTo 0 Application.ScreenUpdating = True End Sub واليك الملف بعد اظافة اكواد الترحيل والتعديل والحدف Dynamic Orders - Pivot_V3.xlsm

نعم ممكن ان تقوم بتغييره كما تريد مع تغييره داخل الكود

تفضل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Q2")) Is Nothing Then 'خلية التنفيد Select Case Range("Q2") 'اسم الماكرو __________________تعريف الماكرو Case "Code1": بحث_واستبدل Case "Code2": معاينة_مع_الطباعة Case "Code3": نسخة_طبق_الأصل_من_الشيت Case "Code4": saad5 Case "Code5": saad6 Case "Code6": saad7 End Select End If End Sub تجربة V1.xlsm

تفضل جرب Sub filtre() Dim sh As Worksheet, sh2 As Worksheet Dim lastRow As Long, lrow As Long, Article As Range Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("c2") Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("A" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجوا ادخال الصنف": Exit Sub Set Article = sh2.Range("D:D").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:E" & lrow).ClearContents sh2.Range("D1").AutoFilter Field:=4, Criteria1:="=" & Rng sh2.Range("A1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("B4").PasteSpecial xlPasteValues sh2.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh2.Range("D2:F" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("C4").PasteSpecial xlPasteValues End With Else m = MsgBox("الصنف " & " " & ST & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True End Sub mywork v2.xlsm

اخي حاول توضيح المطلوب او ارفاق نتيجة للنتائج المتوقعة

جرب اخي استخدام كود الاستاد lionheart فهو يؤدي المطلوب انا وضعت الكود فقط للتنوع واثراء الموضوع لا غير

تفضل جرب اخي لاكن حاول دائما عدم طلب اكثر من طلب في موضوع واحد لكي يستطيع الاساتدة مساعدتك. لا احد لديه الوقت الكافي لاتمام كل الطلبات ...عند الانتهاء من ترحيل البيانات بنجاح قم بفتح وضوع جديد. وسوف نكون سعداء بمساعدتك. بالتوفيق.......... Sub Transfer() ' ترحيل Dim rng As Range, line As Range, cl As Range Dim C As Long, lastrow As Long Dim msg As VbMsgBoxResult Dim WSdata As Worksheet: Set WSdata = Worksheets("Items") Dim WSdest As Worksheet: Set WSdest = Worksheets("Orders") lastrow = WSdest.Cells(WSdest.Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False 'التحقق من وجود بيانات على الخلايا التالية WSdata.Activate Arr = Array([F4], [F6], [H6], [H9], [H9], [F13], [H13], [J13]) For i = 0 To 7 If Arr(i) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -1), vbExclamation, "إنتباه" Arr(i).Select Exit Sub End If Next 'التحقق من وجود اسم العميل مسبقا لمنع التكرار If Application.WorksheetFunction.CountIf(WSdest.Range("D:D"), WSdata.Range("F4").Value) > 0 Then MsgBox "إسم العميل مضاف مسبقا", vbExclamation, "إنتباه" Exit Sub End If ''''''''''''''''''''''''''''''''''''''''''''''''''''''' msg = MsgBox("ترحيل البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "") If msg = vbNo Then Exit Sub Else End If Set rng = WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20,H20") C = 3 For Each cl In rng cl.Copy WSdest.Cells(lastrow + 1, C).PasteSpecial xlPasteValues C = C + 1 Next cl 'تسلسل البيانات With WSdest.Range("B7:B" & lastrow + 1) .Formula = "=Row() - 6" .Value = .Value End With Application.CutCopyMode = False 'حدف الصفوف الفارغة On Error Resume Next Set line = Range("Orders[[إسم العميل]]").SpecialCells(xlCellTypeBlanks) If Not line Is Nothing Then line.Delete Shift:=xlUp End If On Error GoTo 0 'افراغ الخلايا WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,H20") = Empty Application.ScreenUpdating = True m = MsgBox("تم ترحيل البيانات بنجاح", 64, "تأكيد") End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sort_Tbl() Dim sh As Worksheet Dim WStable As ListObject Set sh = ThisWorkbook.Sheets("Data") Set WStable = sh.ListObjects("الجدول1") Application.ScreenUpdating = False With WStable.Sort .SortFields.Clear .SortFields.Add2 Key:=Range("الجدول1[[#All],[المندوب]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlAscending .SortFields.Add2 Key:=Range("الجدول1[[#All],[الدولة]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add2 Key:=Range("الجدول1[[#All],[المنطقة]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlAscending .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub فرز وتصفية.xlsb

العفو اخي احمد تفضل مع اظافة أكواد تحديد أو استثناء أوراق معينة Sub Copy_Data() Dim ws As Worksheet Dim i&, j&, lr As Long For Each ws In Sheets lr = ws.Range("k" & Rows.Count).End(xlUp).Row + 1 ws.Range("k2:L" & lr).ClearContents j = 2 For i = 2 To ws.Range("A" & Rows.Count).End(3).Row If ws.Range("B" & i).Value <> "" Then ws.Range("K" & j & ":L" & j).Value = ws.Range("A" & i & ":B" & i).Value j = j + 1 End If Next Next End Sub بالتوفيق ورقة عمل V2.xlsm

هل ممكن ارفاق صورة او عينة للنتيجة المتوعقة

اليك حل اخر Sub CopyData() Dim x, y(), i&, lr&, ws_rng2&, ws_rng3& Set ws_rng = Sheet1 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row x = ws_rng.Range("A2:B" & lr) For i = 1 To UBound(x, 1) If x(i, 2) <> 0 Then ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3) For ws_rng2 = 1 To UBound(x, 2) y(ws_rng2, ws_rng3) = x(i, ws_rng2) Next End If Next ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y) End Sub آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض ورقة عمل جديد.xlsm

تفضل جرب Private Sub TextBox26_Change() Dim CelF As Range, LigF As Long Set ws = ActiveWorkbook.Sheets("Data") With ws Set lst = ws.ListObjects("الجدول1") If lst.ShowAutoFilter Then lst.ShowAutoFilter = False End If Set CelF = ws.Range("Find").Find(What:=Me.TextBox26, LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigF = CelF.Row Label1.Caption = ws.Range("B" & LigF) Label2.Caption = ws.Range("C" & LigF) Label3.Caption = ws.Range("E" & LigF) Label4.Caption = ws.Range("D" & LigF) Else For S = 1 To 3 Me("Label" & S) = Empty Next S End If End With Label2 = Format(Label2, "dd/mm/yyyy") Label2.BackColor = &H8000000F End Sub TEST V1.xlsb

صراحة لم افهم المطلوب جيدا .

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm

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

لتعديل البيانات لابد من وضع شرط ثابت يمكننا الاعتماد عليه داخل الاكواد وهدا غير متوفر عندك على الملف بحكم ان البيانات في العمود الاول والثاني مكررة في عده صفوف في وجهة نظري افضل طريقة هي استبدال كود الترحيل والاشتغال على انشاء اوراق عمل بشرط القيم الموجودة في عمود التوجيه مع حدف الاوراق السابقة بحيث يتم تحديث جميع اوراق العمل سواءا عند اظافة جديدة او تعديل . هدا ما فهمت من ملفك لحد الساعة . يمكنك توضيح الامر اكثر في حالة ان هدا الحل لا يناسبك. Sub RefreshData() Dim cUnique As Collection Dim rng As Range, cRng As Range Dim Cell As Range, LstRow As Long Dim W_Name As Variant, s As String Dim worksheetexists As Boolean Set WS_Data = ThisWorkbook.Sheets("data") ' الرئيسية Set ST2 = ThisWorkbook.Sheets("اليومية") Set rng = WS_Data.Range("A3:A" & WS_Data.Cells(WS_Data.Rows.Count, "A").End(xlUp).Row) Set cUnique = New Collection Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Delete Next On Error Resume Next For Each Cell In rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each W_Name In cUnique s = W_Name Sheets.Add(After:=Sheets(Sheets.Count)).Name = W_Name ActiveSheet.DisplayRightToLeft = True With WS_Data LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A2").AutoFilter Field:=1, Criteria1:=W_Name Set cRng = .Range("A2:E" & LstRow) cRng.Copy Sheets(s).Range("A2") .Select .Range("A2").AutoFilter ST2.Move After:=Worksheets(Worksheets.Count) End With For Each ws In Sheets If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Columns("A:E").ColumnWidth = 21 Next Next W_Name Application.ScreenUpdating = True WS_Data.Activate End Sub استدعاء من عدة شيتات V2.xlsm

تفضل جرب بحث واستبدال حسب قيم خليتين.xlsm

تفضل اخي Private Sub CommandButton2_Click() Dim p As String, NwPath As String Dim file As Variant Dim copyToFolder As String Set wb = ThisWorkbook 'قم بتعديل المسار الخاص بك NwPath = "C:\Users\hicham\Documents\test" file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه") If file = False Then Exit Sub copyToFolder = filePath If copyToFolder <> Left(file, InStrRev(file, "\")) Then p = InStrRev(file, "\") If Right(NwPath, 1) = "\" Then p = p + 1 FileCopy file, NwPath & Mid(file, p) End If MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & NwPath & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" End Sub الارشيف v3.xlsb

العفو اخي اليك حل اخر في حالة الرغبة بنسخ البيانات في اخر صف فارغ Public Sub transfer_data() Dim ws_Data As Worksheet Dim WS_Sheets_Name As Variant Dim Rng As Range, LR As Long Set ws_Data = ThisWorkbook.Worksheets("saad") Application.ScreenUpdating = False 'ws_Data.Range("c14:t1000").ClearContents For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) Set st = ws_Data.Range("R12") With WS_Sheets Set Rng = .Range("C9:T" & .Cells(.Rows.Count, "C").End(xlUp).Row) End With With Rng Dim cntCrit As Long cntCrit = WorksheetFunction.CountIfs(Rng.Columns(16), st) If cntCrit <> 0 Then .AutoFilter Field:=16, Criteria1:=st LR = ws_Data.Range("C" & Rows.Count).End(xlUp).Row + 1 .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy ws_Data.Range("C" & LR).PasteSpecial (xlPasteValues) End If .Parent.AutoFilterMode = False End With Next WS_Sheets End Sub way 3.xlsm

بعد ادن الاستاد الفاضل @ابراهيم الحداد جرب اخي Sub GetData() Dim Sh As Worksheet Dim WS_Sheets_Name As Variant Dim LR As Long, Countr As Long, p As Long Dim Arr(), Fsl As String, C As Range, j As Long Set Sh = Sheets("saad") Sh.Range("C14:T1000") = "" Fsl = Sh.Range("R12") For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) LR = WS_Sheets.Range("C" & Rows.Count).End(3).Row Countr = Countr + LR Next WS_Sheets ReDim Preserve Arr(Countr, 18) For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) For Each C In WS_Sheets.Range("C10:C" & LR) If C.Offset(0, 15).Value = Fsl Then p = p + 1 For j = 0 To 17 Arr(p - 1, j) = C.Offset(0, j) Arr(p - 1, 0) = p Next End If Next Next WS_Sheets If p > 0 Then Sh.Range("C14").Resize(p, UBound(Arr, 2)).Value = Arr End Sub way 2.xlsm