نقل البيانات بين اكثر من ملف

[mahmoud nasr alhasany]

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

يوجد مشكلة فى الكود

اريد التعديل على الكود للتعامل مع عدة ملفات مصدر بدلاً من ملف واحد

وهى نقل البيانات من عدة ملفات مصدر إلى ملف وجهة واحد.

Sub نقل_البيانات_بين_الملفات_محسن()

  ' تعريف المتغيرات
  Dim wbDest As Workbook, wbSource As Workbook
  Dim wsDest As Worksheet, wsSource As Worksheet
  Dim lastRowDest As Long
  Dim i As Long, j As Long
  Dim sourceData As Variant, wsName As String
  Dim filePath As String
  Dim fileNames As Variant ' مصفوفة لتخزين أسماء الملفات
  Dim fileName As Variant
  Dim sheetNames As Variant
  Dim sheetName As Variant
  Dim headers As Variant
  Dim محافظة As String
  Dim dataDict As Object

  ' تعطيل تحديث الشاشة والحساب التلقائي لتسريع التنفيذ
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  ' تعيين ملف الوجهة (الملف الحالي)
  Set wbDest = ThisWorkbook

  ' مصفوفة أسماء الملفات المصدر (يمكنك تعديل هذه القائمة)
  fileNames = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _
                  "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _
                  "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _
                  "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _
                  "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _
                  "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _
                  "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _
                  "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _
                  "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _
                  "رصيد التوكيلات_ادفو.xlsx")

  ' مصفوفة أسماء الأوراق المطلوبة (المحافظات) - يجب أن تتطابق مع أسماء الأوراق في الملفات المصدر
  sheetNames = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _
                  "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _
                  "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _
                  "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الغردقة", "الاقصر", "اسوان", "ادفو")

  ' إنشاء قاموس لتخزين البيانات من الملفات المصدر
  Set dataDict = CreateObject("Scripting.Dictionary")

  ' المرور على كل ملف من ملفات المصدر
  For Each fileName In fileNames

    ' بناء مسار الملف الكامل
    filePath = ThisWorkbook.Path & "\" & fileName

    ' فتح الملف المصدر مع معالجة الأخطاء
    On Error Resume Next ' تخطي الخطأ إذا كان الملف مفتوحًا بالفعل
    Set wbSource = Workbooks(fileName)
    On Error GoTo 0

    If wbSource Is Nothing Then ' إذا لم يتم العثور على الملف المفتوح
      On Error Resume Next ' تخطي الخطأ إذا لم يتم العثور على الملف
      Set wbSource = Workbooks.Open(filePath)
      On Error GoTo 0

      If wbSource Is Nothing Then ' إذا لم يتم فتح الملف
        MsgBox "لم يتم العثور على الملف: " & filePath, vbCritical
        GoTo SkipFile ' الانتقال إلى الملف التالي
      End If
    End If

    ' المرور على أوراق العمل في الملف المصدر
    For Each wsSource In wbSource.Sheets
      محافظة = wsSource.Name

      ' قراءة البيانات والعناوين من ورقة العمل
      sourceData = wsSource.Range("B3:S71").Value
      headers = wsSource.Range("F3:S3").Value

       ' تخزين البيانات في القاموس باستخدام اسم المحافظة كمفتاح
      If Not dataDict.Exists(محافظة) Then
        dataDict.Add محافظة, sourceData
      End If
    Next wsSource

    ' إغلاق الملف المصدر بعد الانتهاء من قراءة البيانات منه
    wbSource.Close SaveChanges:=False

SkipFile: ' علامة لتخطي الملف في حالة عدم وجوده
  Next fileName

  ' الآن، dataDict يحتوي على البيانات من جميع الملفات

  ' المرور على أسماء المحافظات لنقل البيانات إلى الملف الوجهة
  For Each sheetName In sheetNames

    ' البحث عن ورقة العمل في ملف الوجهة، وإنشائها إذا لم تكن موجودة
    On Error Resume Next
    Set wsDest = wbDest.Sheets(sheetName)
    On Error GoTo 0

    If wsDest Is Nothing Then
      Set wsDest = wbDest.Sheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count))
      wsDest.Name = sheetName
    End If

    ' كتابة العناوين في ورقة العمل إذا كانت فارغة
    If wsDest.Cells(1, 6).Value = "" Then
      wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers
    End If

    ' إذا كانت البيانات موجودة في القاموس، انقلها إلى ورقة العمل
    If dataDict.Exists(sheetName) Then
      sourceData = dataDict(sheetName)

      ' تحديد الصف الأخير في ورقة العمل
       lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1 ' تعديل لايجاد اخر صف

      ' تجهيز البيانات للنقل (تخطي الأعمدة من 1 إلى 4)
      Dim outputData As Variant
      ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4)

      For i = 1 To UBound(sourceData, 1)
        For j = 5 To UBound(sourceData, 2)
          outputData(i, j - 4) = sourceData(i, j)
        Next j
      Next i

      ' نقل البيانات إلى ورقة العمل
      wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
    End If
  Next sheetName

  ' استعادة إعدادات Excel
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic

  MsgBox "تم نقل البيانات بنجاح.", vbInformation

End Sub

 

نقل البيانات بين الملفات.rar

تم تعديل الثلاثاء at 16:51 بواسطه mahmoud nasr alhasany

[محمد هشام.]

تفضل جرب هدا التعديل  

Option Explicit
Sub test()
    Dim wbDest As Workbook, wbData As Workbook
    Dim WS As Worksheet, CrWS As Worksheet
    Dim Irow&, nRow&, xPath$, xFile$, fname As Variant
    Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range
    Dim WSIndex As Integer

    SetApp False
    xPath = ThisWorkbook.Path
    
    fname = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _
                  "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _
                  "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _
                  "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _
                  "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _
                  "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _
                  "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _
                  "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _
                  "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _
                  "رصيد التوكيلات_ادفو.xlsx")
    
    ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _
                  "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _
                  "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _
                  "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو")

    Set wbData = ThisWorkbook
    On Error Resume Next
    Set wbDest = Workbooks.Open(xPath & "\" & fname(0), ReadOnly:=True)
    If wbDest Is Nothing Then
        MsgBox "تعذر العثور على الملف " & fname(0), vbCritical
        SetApp True
        Exit Sub
    End If
    On Error GoTo 0

    For WSIndex = LBound(fname) To UBound(fname)
        xFile = xPath & "\" & fname(WSIndex)

        On Error Resume Next
        Set wbDest = Workbooks.Open(xFile, ReadOnly:=True)
        If wbDest Is Nothing Then
            MsgBox "تعذر العثور على الملف " & fname(WSIndex), vbCritical
            SetApp True
            Exit Sub
        End If
        On Error GoTo 0

        For i = LBound(ShArr) To UBound(ShArr)
            On Error Resume Next
            Set CrWS = wbData.Sheets(ShArr(i))
            On Error GoTo 0

            If Not CrWS Is Nothing Then
                Set WS = Nothing
                On Error Resume Next
                Set WS = wbDest.Sheets(ShArr(i))
                On Error GoTo 0
                
                If Not WS Is Nothing Then
                    Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row

                    If Irow < 4 Then
                        GoTo SkipSheet
                    End If

                    For j = 6 To 19
                        Set tmps = CrWS.Cells(3, j)

                        For k = 6 To 19
                            Set OnRng = WS.Cells(3, k)

                            If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then
                                For nRow = 4 To 71
                                    If Not IsEmpty(WS.Cells(nRow, k).Value) Then
                                        CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value
                                    End If
                                Next nRow
                                Exit For
                            End If
                        Next k
                    Next j

                    For nRow = 4 To 71
                        If Not IsEmpty(WS.Cells(nRow, 2).Value) Then
                            CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value
                        End If
                    Next nRow
                End If
            End If

SkipSheet:
        Next i

SkipFile:
        wbDest.Close False
    Next WSIndex

    MsgBox "تم نقل البيانات من جميع الملفات بنجاح", vbInformation
    SetApp True
End Sub

Private Sub SetApp(ByVal enable As Boolean)
    On Error Resume Next
    Application.ScreenUpdating = enable
    Application.EnableEvents = enable
    Application.DisplayAlerts = enable
    Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
End Sub

 

نقل البيانات من مصنفات متعددة.rar

تم تعديل الثلاثاء at 17:30 بواسطه محمد هشام.

[mahmoud nasr alhasany]

تمام احسنت الف شكر لك استاذنا الفاضل  /   محمد هشام