كود مميز لتبادل البيانات بين ملفات بحاجة الى تعديل

[خالد القدس2]

الاساتذة الكرام  
السلام عليكم ورحة الله وبركاته  
تقبل الله منا ومنكم صالح الاعمال 
وكل عام وانتم بخير وعافية ونعم ظاهرة وباطنة  

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

رابط الملفات حيث حجمها كبير
https://www.mediafire.com/file/6nqdhfbiqddkd3o/asa.rar/file



 

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wb As Workbook
    Dim rngSource As Range, rngTarget As Range
    Dim arrFiles As Variant
    Dim conn As Object, rs As Object
    Dim filePath As String
    Dim i As Long, lastRow As Long

    If IsSyncing Then Exit Sub
    If Sh.CodeName <> "Sheet1" Then Exit Sub
    If Intersect(Target, Sh.Range("A1:CV1")) Is Nothing Then Exit Sub

    IsSyncing = True

    ' تحديد الصف الأخير الفارغ في العمود B داخل الملف الرئيسي
    lastRow = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
    Set rngSource = Sh.Range("A1:CV" & lastRow)

    ' تحديد المسارات ديناميكيًا اعتمادًا على موقع ملف Excel الحالي
    arrFiles = Array(ThisWorkbook.Path & "\asa1.xlsm", _
                     ThisWorkbook.Path & "\asa2.xlsm", _
                     ThisWorkbook.Path & "\asa3.xlsm", _
                     ThisWorkbook.Path & "\asa4.xlsm")

    For i = 0 To UBound(arrFiles)
        On Error Resume Next
        Set wb = Application.Workbooks(arrFiles(i))
        On Error GoTo 0

        If Not wb Is Nothing Then
            ' إذا كان الملف مفتوحًا، يتم التعديل مباشرة في الجدول
            lastRow = wb.Sheets("data").Cells(wb.Sheets("data").Rows.Count, 2).End(xlUp).Row
            Set rngTarget = wb.Sheets("data").Range("A1:CV" & lastRow)
            rngTarget.Value = rngSource.Value
        Else
            ' إنشاء الاتصال بـ ADO
            Set conn = CreateObject("ADODB.Connection")

            filePath = arrFiles(i)
            conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filePath & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"";"

            ' التحقق من أن الاتصال مفتوح قبل تنفيذ أي استعلام
            If conn.State = 1 Then
                ' استدعاء أسماء الجداول المتاحة للتحقق من وجود Table1
                Set rs = conn.OpenSchema(20) ' 20 = adSchemaTables
                Do While Not rs.EOF
                    Debug.Print rs.Fields("TABLE_NAME").Value
                    rs.MoveNext
                Loop
                rs.Close

                ' تنفيذ التحديث فقط إذا كان الجدول موجودًا
                conn.Execute "UPDATE [data$] SET F1='" & rngSource.Cells(1, 1).Value & "' WHERE F1 IS NOT NULL"
            Else
                MsgBox "فشل في فتح الاتصال بالملف: " & filePath, vbExclamation, "خطأ في الاتصال"
            End If

            conn.Close
            Set conn = Nothing
        End If
    Next i

    IsSyncing = False
End Sub

 

[أبوعيد]

وعليكم السلام ورحمة الله وبركاته

أخي لو أنك ترسل نموذج من الملفات فإنك ستلقى حلا لمشكلتك

بمعنى تقوم بحذف جزء كبير من البيانات في كل ملف نموذج حتى يقل حجمه

ثم ترفقها هنا للعمل عليها

تم تعديل منذ 59 دقائق بواسطه أبوعيد