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

mahmoud nasr alhasany · فبراير 14

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

اريد المساعدة يوجد خطاء فى الكود

نقل البيانات من ملف "رصيد التوكيلات1.xlsx" الى ملف "رصيد التوكيلات. XLM" على حسب كود الصنف من B3:B71 وصف التاريخ من F3:S3 والبيانات التابعة لكل صنف من F4:S71 فى ورقة شيت كل محافظة



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

  Dim wbSource As Workbook, wbDest As Workbook
  Dim wsSource As Worksheet, wsDest As Worksheet
  Dim lastRowSource As Long, lastColSource As Long
  Dim lastRowDest As Long
  Dim i As Long, j As Long
  Dim itemCode As String, monthDate As String
  Dim sourceData As Variant, wsName As String
  Dim filePath As String
  Dim wsFoundSource As Boolean
  Dim sheetNames As Variant
  Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق

  ' تعيين الكائنات
  Set wbDest = ThisWorkbook

  ' تحديد مسار الملف المصدر
  filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx"

  ' فتح الملف المصدر مع معالجة الأخطاء
  On Error Resume Next
  Set wbSource = Workbooks("رصيد التوكيلات1.xlsx")
  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
      Exit Sub
    End If
  End If

  ' تحديد النطاق في ملف المصدر
  With wbSource.Sheets(1) ' يمكنك تغيير رقم 1 إلى اسم ورقة العمل إذا كانت مختلفة
    sourceData = .Range("F4:S71").Value ' تحديد النطاق F4:S71
  End With


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

  ' تكرار على أسماء الأوراق
  For Each sheetName In sheetNames

    ' البحث عن الورقة المطلوبة في ملف الوجهة
    On Error Resume Next
    Set wsDest = wbDest.Sheets(sheetName)
    On Error GoTo 0

    ' إذا تم العثور على الورقة في ملف الوجهة
    If Not wsDest Is Nothing Then

      ' إدخال البيانات في ورقة العمل الوجهة
      If Not IsEmpty(sourceData) Then

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

        ' نقل البيانات من المصفوفة إلى ورقة العمل
        For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة
          For j = 1 To UBound(sourceData, 2) ' الأعمدة في المصفوفة
            wsDest.Cells(lastRowDest + i - 1, j + 5).Value = sourceData(i, j) ' بدءًا من العمود G (العمود 7)
          Next j
        Next i

      End If

    End If

  Next sheetName

  ' إغلاق الملف المصدر (اختياري)
  wbSource.Close SaveChanges:=False

End Sub

تم تعديل فبراير 14 بواسطه mahmoud nasr alhasany

mahmoud nasr alhasany · فبراير 14

لقد وجدت الحل ولاكن توجد مشكلة وهى ان استدعاء البيانات بيأخذ وقت كتير لكثرة اوراق العمل

هل يوجد كود بديل واسرع من هذا الكود


Sub نقل_البيانات_بين_الملفات46()
  Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lastRowSource As Long, lastColSource As Long
Dim lastRowDest As Long
Dim i As Long, j As Long, k As Long
Dim itemCode As String, monthDate As String
Dim sourceData As Variant, wsName As String
Dim filePath As String
Dim wsFoundSource As Boolean
Dim sheetNames As Variant
Dim sheetName As Variant ' متغير لحلقة التكرار على الأوراق
Dim headers As Variant ' متغير لتخزين العناوين
Dim محافظة As String

Set wbDest = ThisWorkbook
 ' تحديد مسار الملف المصدر
 filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx"
 ' فتح الملف المصدر مع معالجة الأخطاء
On Error Resume Next
Set wbSource = Workbooks("رصيد التوكيلات1.xlsx")
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
Exit Sub
End If

End If

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

 ' تكرار على أوراق العمل في ملف المصدر

For Each wsSource In wbSource.Sheets
 ' الحصول على اسم المحافظة من اسم ورقة العمل
 محافظة = wsSource.Name
 ' قراءة البيانات من ورقة العمل الحالية إلى مصفوفة لتسريع العملية
 sourceData = wsSource.Range("B3:S71").Value ' يشمل كود الصنف والمحافظة
 ' تخزين العناوين في متغير
 headers = wsSource.Range("F3:S3").Value
 ' تكرار على أسماء الأوراق الهدف

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
 ' الآن wsDest يشير إلى ورقة العمل الصحيحة، سواء كانت موجودة أو تم إنشاؤها

 ' تحديد الصف الأخير في ورقة العمل الوجهة بطريقة أكثر دقة
 lastRowDest = 2 ' ابدأ من الصف الثاني (بعد العناوين)
 ' كتابة العناوين في ورقة العمل الوجهة (مرة واحدة فقط)
 ' **فحص ما إذا كانت العناوين موجودة بالفعل قبل كتابتها**
If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة
 wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F

End If

 ' إدخال البيانات في ورقة العمل الوجهة
If Not IsEmpty(sourceData) Then
 ' نقل البيانات من المصفوفة إلى ورقة العمل

For i = 1 To UBound(sourceData, 1) ' الصفوف في المصفوفة
 ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames
If IsError(Application.Match(محافظة, sheetNames, 0)) Then
 ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف
Debug.Print "تحذير: اسم المحافظة '" & محافظة & "' غير موجود في قائمة المحافظات."
GoTo SkipRow ' انتقل إلى الصف التالي
End If
 ' التحقق من تطابق اسم المحافظة مع اسم ورقة العمل الهدف
If محافظة = sheetName Then
For j = 5 To UBound(sourceData, 2) ' الأعمدة في المصفوفة (من F إلى S)
 wsDest.Cells(lastRowDest + i, j + 1).Value = sourceData(i, j) ' ابدأ من العمود F (العمود 6)
Next j
End If

SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة

        Next i

      End If

    Next sheetName

  Next wsSource ' انتهاء التكرار على أوراق العمل في ملف المصدر

  ' إغلاق الملف المصدر (اختياري)
  wbSource.Close SaveChanges:=False

End Sub

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

مالخطاء هنا


Sub نقل_البيانات_بين_الملفات46_محسّن()
    Dim wbSource As Workbook, wbDest As Workbook
    Dim wsSource As Worksheet, wsDest 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 sheetNames As Object ' Dictionary لتخزين أسماء الأوراق
    Dim sheetName As Variant
    Dim headers As Variant
    Dim محافظة As String
    Dim outputData As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set wbDest = ThisWorkbook
    filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx"

    ' فتح الملف المصدر مع معالجة الأخطاء
    On Error Resume Next
    Set wbSource = Workbooks("رصيد التوكيلات1.xlsx")
    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
            Exit Sub
        End If
    End If

    ' إنشاء Dictionary لتخزين أسماء الأوراق
    Set sheetNames = CreateObject("Scripting.Dictionary")
    sheetNames.Add "الاسكندرية", 1
    sheetNames.Add "كفرالشيخ", 1
    sheetNames.Add "البحيرة", 1
    sheetNames.Add "طنطا", 1
    sheetNames.Add "المنصورة", 1
    sheetNames.Add "دكرنس", 1
    sheetNames.Add "دمياط", 1
    sheetNames.Add "المنوفية", 1
    sheetNames.Add "الشرقية", 1
    sheetNames.Add "الاسماعيلية", 1
    sheetNames.Add "بور سعيد", 1
    sheetNames.Add "السويس", 1
    sheetNames.Add "المقطم", 1
    sheetNames.Add "مؤسسة الزكاة", 1
    sheetNames.Add "الجيزة", 1
    sheetNames.Add "القليوبية", 1
    sheetNames.Add "الفيوم", 1
    sheetNames.Add "بنى سويف", 1
    sheetNames.Add "المنيا", 1
    sheetNames.Add "اسيوط", 1
    sheetNames.Add "سوهاج", 1
    sheetNames.Add "جرجا", 1
    sheetNames.Add "قنا", 1
    sheetNames.Add "نجع حمادى", 1
    sheetNames.Add "الغردقة", 1
    sheetNames.Add "الاقصر", 1
    sheetNames.Add "اسوان", 1
    sheetNames.Add "ادفو", 1

    For Each wsSource In wbSource.Sheets
        محافظة = wsSource.Name

        ' استخدام النطاقات المُعرّفة (تأكد من تعريفها في ملف المصدر)
        On Error Resume Next ' للتعامل مع الأوراق التي قد لا تحتوي على نطاق مُعرّف
        sourceData = wsSource.Range("DataRange_" & محافظة).Value
        
         On Error GoTo 0

        ' إذا لم يتم العثور على النطاق المُعرّف، استخدم النطاق الافتراضي
        If IsEmpty(sourceData) Then
            sourceData = wsSource.Range("B3:S71").Value
        End If

        headers = wsSource.Range("F3:S3").Value

        For Each sheetName In sheetNames.Keys
            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


            lastRowDest = wsDest.Cells(Rows.Count, "F").End(xlUp).Row + 1

            
            If wsDest.Cells(1, 6).Value = "" Then ' إذا كانت الخلية فارغة، فهذا يعني أن العناوين غير موجودة
            wsDest.Cells(1, 6).Resize(1, UBound(headers, 2)).Value = headers ' كتابة العناوين في الصف الأول، بدءًا من العمود F
            End If

            ReDim outputData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2) - 4)

            If Not IsEmpty(sourceData) Then
                For i = 1 To UBound(sourceData, 1)
                    If محافظة = sheetName Then
                        For j = 5 To UBound(sourceData, 2)
                            outputData(i, j - 4) = sourceData(i, j)
                        Next j
                    End If
                Next i

                wsDest.Cells(lastRowDest, 6).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
            End If
        Next sheetName
    Next wsSource

    wbSource.Close SaveChanges:=False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

رصيد التوكيلات1.xlsx رصيد التوكيلات.xlsm

تم تعديل فبراير 14 بواسطه mahmoud nasr alhasany

mahmoud nasr alhasany · فبراير 16

هل يوجد احد بأمكانة مساعدتى

**محمد هشام.** · الإثنين at 21:38

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

جرب هدا

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

    SetApp False
    xPath = ThisWorkbook.Path
    fname = "رصيد التوكيلات1"
    xFile = xPath & "\" & fname & ".xlsx"
    
    If Dir(xFile) = "" Then
        MsgBox "تعذر العثور على الملف " & fname, vbCritical
        SetApp True
        Exit Sub
    End If
    
    Set wbData = ThisWorkbook
    ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _
                   "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _
                   "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _
                   "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو")

    On Error Resume Next
    Set wbDest = Workbooks.Open(xFile, ReadOnly:=True)
    If wbDest Is Nothing Then
        SetApp True
        Exit Sub
    End If
    On Error GoTo 0

    For i = LBound(ShArr) To UBound(ShArr)
        On Error Resume Next
        Set WS = wbDest.Sheets(ShArr(i))
        Set CrWS = wbData.Sheets(ShArr(i))
        On Error GoTo 0
        
        If Not WS Is Nothing And Not CrWS Is Nothing Then
            Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
            If Irow >= 4 Then
                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
    Next i

wbDest.Close False

Cleanup:
    SetApp True
    MsgBox "تم نقل البيانات بنجاح", vbInformation
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 23:43 بواسطه محمد هشام.

mahmoud nasr alhasany · الثلاثاء at 07:27

لقد وجدت الحل ايضا واشكر استاذنا / محمد هشام على مساعدتنا فى حل المشكلة

وارجح كود ا / محمد هشام


Sub نقل_البيانات_بين_الملفات_محسن()
    Dim wbSource As Workbook, wbDest As Workbook
    Dim wsSource As Worksheet, wsDest 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 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
    filePath = ThisWorkbook.Path & "\رصيد التوكيلات1.xlsx"

    ' فتح الملف المصدر مع معالجة الأخطاء
    On Error Resume Next
    Set wbSource = Workbooks("رصيد التوكيلات1.xlsx")
    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
            Exit Sub
        End If
    End If

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

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

    For Each wsSource In wbSource.Sheets
        محافظة = wsSource.Name
        sourceData = wsSource.Range("B3:S71").Value
        headers = wsSource.Range("F3:S3").Value

        ' تخزين البيانات في القاموس
        dataDict.Add محافظة, sourceData
    Next wsSource

    For Each sheetName In sheetNames
        On Error Resume Next
        Set wsDest = wbDest.Sheets(sheetName)
        On Error GoTo 0
        lastRowDest = 3 ' ابدأ من الصف الثالث

        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)
            ' تعديل هنا: تحديد الصف الأخير داخل النطاق F3:S71
            lastRowDest = wsDest.Range("F3:F71").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row '+ 1

            ' التحقق من وجود اسم المحافظة في مصفوفة sheetNames
            If IsError(Application.Match(sheetName, sheetNames, 0)) Then
                ' إذا لم يتم العثور على اسم المحافظة، تخطي هذا الصف
                Debug.Print "تحذير: اسم المحافظة '" & sheetName & "' غير موجود في قائمة المحافظات."
                GoTo SkipRow ' انتقل إلى الصف التالي
            End If

            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

SkipRow: ' تسمية العلامة لتخطي الصف في حالة عدم تطابق اسم المحافظة
            wsDest.Range("F" & lastRowDest).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
        End If
    Next sheetName

    wbSource.Close SaveChanges:=False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

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

تسجيل الدخول

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

الردود الموصى بها

mahmoud nasr alhasany

mahmoud nasr alhasany

mahmoud nasr alhasany

محمد هشام.

mahmoud nasr alhasany

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information