نجوم المشاركات

عذرا اليك الملف ASD1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الذكر من طرف الأستاذ @طارق محمود أنسب طريقة لتنفيد طلبك على ما أعتقد هي إستخدام الأكواد خاصة إذا كانت لك رغبة بالإشتغال على الملفات وهي مغلقة مع وضع عدة معايير للتحقق يمكنك تجربة هدا الاقتراح ربما يناسبك يكفي وضع مصنف المطابقة في نفس مسار الملفات سيتم تحديث البيانات تلقائيا Sub CopyData() '''''''''( رصيد عملاء Workbook ) Dim FileName$, Path$, wbSource$, rng As Range, FilePath$, sPath$ Dim src As Worksheet: Set src = Sheets("1") Path = ThisWorkbook.Path wbSource = "رصيد عملاء.xlsx": FileName = src.[A1] If FileName = "" Then: Exit Sub ' التححق من وجود المصنف FilePath = Path & "\" & wbSource If Len(Dir(FilePath)) = 0 Then MsgBox "الملف غير موجود", vbExclamation, wbSource: Exit Sub End If ' التححق من وجود ورقة العمل sPath = ActiveWorkbook.Path & "\" If Not Verification(sPath, wbSource, FileName) Then MsgBox wbSource & " " & " الورقة " & " : " & FileName & " غير موجودة على مصنف", vbInformation: Exit Sub End If With Application .ScreenUpdating = False .DisplayAlerts = False src.Range("B3:P" & src.Rows.Count).ClearContents a = "B3:B300": b = "C3:C300": c = "D3:P300" '<<===== ' Paste data(المطابقة) Cnt = "Q12:Q300": Cnt2 = "S12:S300": Cnt3 = "CB12:CN300" '<<===== 'Data range(رصيد عملاء) 'كود المنتج src.Range(a).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt 'المنتج src.Range(b).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt2 ' من يناير الى الإجمالى src.Range(c).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt3 ling = src.UsedRange.Rows.Count: Set rng = src.Range("B3:P" & ling) With rng .Value = .Value: .Borders.LineStyle = xlNone .Replace "#N/A", "", xlWhole: .Replace "0", "", xlWhole End With ' Underline the rows Sheets("1") For Each c In rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next .ScreenUpdating = False .DisplayAlerts = False End With End Sub Sub CopyData2() '''''''''''''( عملاء Workbook ) Dim FileName$, Path$, wbSource$, rng As Range, FilePath$, sPath$ Dim src As Worksheet: Set src = Sheets("1") Path = ThisWorkbook.Path wbSource = "عملاء.xlsx": FileName = src.[R1] If FileName = "" Then: Exit Sub FilePath = Path & "\" & wbSource If Len(Dir(FilePath)) = 0 Then MsgBox "الملف غير موجود", vbExclamation, wbSource: Exit Sub End If sPath = ActiveWorkbook.Path & "\" If Not Verification(sPath, wbSource, FileName) Then MsgBox wbSource & " " & " الورقة " & " : " & FileName & " غير موجودة على مصنف", vbInformation: Exit Sub End If With Application .ScreenUpdating = False .DisplayAlerts = False src.Range("S3:AG" & src.Rows.Count).ClearContents a = "S3:S300": b = "T3:T300": c = "U3:AG300" '<<===== ' Paste data(المطابقة) Cnt = "Y4:Y300": Cnt2 = "Z4:Z300": Cnt3 = "FK4:FW300" '<<===== 'Data range(عملاء) 'كود المنتج src.Range(a).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt 'المنتج src.Range(b).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt2 ' من يناير الى الإجمالى src.Range(c).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt3 ling = src.UsedRange.Rows.Count: Set rng = src.Range("S3:AG" & ling) With rng .Value = .Value: .Borders.LineStyle = xlNone .Replace "#N/A", "", xlWhole: .Replace "0", "", xlWhole End With ' Underline the rows Sheets("1") For Each c In rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next .ScreenUpdating = False .DisplayAlerts = False End With End Sub Function Verification(fPath As String, fName As String, sheetName As String) Dim f As String f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1" Verification = Not IsError(Application.ExecuteExcel4Macro(f)) End Function Sheets("1") وفي حدث Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Select Case Target.Address(0, 0) Case "A1": Call CopyData: Case "R1": Call CopyData2 Target.Select Case Else: Exit Sub End Select End Sub Workbook event Private Sub Workbook_Open() Call CopyData: Call CopyData2 End Sub إستدعاء بيانات.zip

السلام عليكم الاخ الكريم / زاكي بوشلاغم بارك الله فيك هل تقصد هكذا .... شاهد المرفق كود عدم حفظ الملف الا بشرط.rar