Note: The other languages of the website are Google-translated. Back to English

كيفية إجراء حلقة عبر الملفات في دليل ونسخ البيانات إلى ورقة رئيسية في Excel؟

لنفترض أن هناك العديد من مصنفات Excel في مجلد ، وتريد تكرار كل ملفات Excel هذه ونسخ البيانات من نطاق محدد من أوراق العمل ذات الاسم نفسه إلى ورقة عمل رئيسية في Excel ، فماذا يمكنك أن تفعل؟ تقدم هذه المقالة طريقة لتحقيق ذلك بالتفصيل.

قم بالتكرار خلال الملفات الموجودة في دليل وانسخ البيانات إلى ورقة رئيسية برمز VBA


قم بالتكرار خلال الملفات الموجودة في دليل وانسخ البيانات إلى ورقة رئيسية برمز VBA

إذا كنت ترغب في نسخ البيانات المحددة في النطاق A1: D4 من كافة أوراق المصنفات الموجودة في مجلد معين إلى ورقة رئيسية ، فيرجى القيام بما يلي.

1. في المصنف الذي ستقوم بإنشاء ورقة عمل رئيسية ، اضغط على قديم + F11 مفاتيح لفتح ميكروسوفت فيسوال باسيك للتطبيقات نافذة.

2. في ال ميكروسوفت فيسوال باسيك للتطبيقات الإطار، انقر فوق إدراج > وحدة. ثم انسخ رمز VBA أدناه في نافذة الكود.

كود فبا: تكرار الملفات في مجلد وانسخ البيانات إلى ورقة رئيسية

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

ملاحظة:

1). في الكود ، "A1: D4"و"Sheet1"يعني أنه سيتم نسخ البيانات الموجودة في النطاق A1: D4 من كل ورقة 1 إلى الورقة الرئيسية. و "ورقة جديدة"هو اسم الورقة الرئيسية المنشأة الجديدة.
2). يجب ألا تفتح ملفات Excel في المجلد المحدد.

3. اضغط على F5 مفتاح لتشغيل الكود.

4. في الافتتاح تصفح نافذة ، يرجى تحديد المجلد الذي يحتوي على الملفات التي ستمررها ، ثم انقر فوق OK زر. انظر لقطة الشاشة:

ثم يتم إنشاء ورقة عمل رئيسية تسمى "ورقة جديدة" في نهاية المصنف الحالي. ويتم سرد البيانات الموجودة في النطاق A1: D4 لكل Sheet1 في المجلد المحدد داخل ورقة العمل.


مقالات ذات صلة:


أفضل أدوات إنتاجية المكتب

Kutools for Excel يحل معظم مشاكلك ويزيد إنتاجيتك بنسبة 80٪

  • إعادة استخدام: أدخل بسرعة الصيغ المعقدة والرسوم البيانية وأي شيء استخدمته من قبل ؛ تشفير الخلايا مع كلمة السر إنشاء قائمة بريدية وإرسال رسائل البريد الإلكتروني ...
  • سوبر فورميولا بار (بسهولة تحرير أسطر متعددة من النص والصيغة) ؛ تخطيط القراءة (قراءة وتحرير أعداد كبيرة من الخلايا بسهولة) ؛ لصق في النطاق المصفى
  • دمج الخلايا / الصفوف / الأعمدة دون فقدان البيانات ؛ تقسيم محتوى الخلايا ؛ ادمج الصفوف / الأعمدة المكررة... منع تكرار الخلايا؛ قارن النطاقات
  • حدد مكرر أو فريد صفوف حدد صفوف فارغة (جميع الخلايا فارغة) ؛ البحث الفائق والبحث الغامض في العديد من المصنفات. تحديد عشوائي ...
  • نسخة طبق الأصل خلايا متعددة بدون تغيير مرجع الصيغة ؛ إنشاء المراجع تلقائيًا إلى أوراق متعددة أدخل الرموز النقطية، مربعات الاختيار والمزيد ...
  • استخراج النص، إضافة نص ، إزالة حسب الموضع ، إزالة الفضاء؛ إنشاء وطباعة المجاميع الفرعية لترحيل الصفحات ؛ التحويل بين محتوى الخلايا والتعليقات
  • سوبر تصفية (حفظ وتطبيق مخططات التصفية على أوراق أخرى) ؛ فرز متقدم حسب الشهر / الأسبوع / اليوم ، التكرار والمزيد ؛ مرشح خاص بواسطة bold، italic ...
  • اجمع بين المصنفات وأوراق العمل؛ دمج الجداول على أساس الأعمدة الرئيسية ؛ تقسيم البيانات إلى أوراق متعددة; تحويل دفعة xls و xlsx و PDF
  • أكثر من 300 ميزة قوية. يدعم Office / Excel 2007-2021 و 365. يدعم جميع اللغات. سهولة النشر في مؤسستك أو مؤسستك. الميزات الكاملة نسخة تجريبية مجانية لمدة 30 يومًا. ضمان استرداد الأموال لمدة 60 يومًا.
علامة تبويب kte 201905

يجلب Office Tab الواجهة المبوبة إلى Office ، ويجعل عملك أسهل بكثير

  • تمكين التحرير والقراءة المبوبة في Word و Excel و PowerPointوالناشر والوصول و Visio والمشروع.
  • فتح وإنشاء مستندات متعددة في علامات تبويب جديدة من نفس النافذة ، بدلاً من النوافذ الجديدة.
  • يزيد من إنتاجيتك بنسبة 50٪ ، ويقلل مئات النقرات بالماوس كل يوم!
أوفيسيتاب القاع
فرز التعليقات حسب
التعليقات (20)
لا يوجد تقييم. كن أول من يقيم!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
شكرا لك على كود vba! إنه يعمل بشكل مثالي! هل ترغب في معرفة ما هو الرمز إذا كنت بحاجة إلى لصقه كقيمة بدلاً من ذلك؟ شكرا مقدما!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا لاي لينغ ،
يمكن أن تساعدك الكود التالي في حل المشكلة. شكرا لك على تعليقك.

Sub Merge2MultiSheets ()
خافت xRg كمدى
خافت xSelItem كمتغير
خافت xFileDlg كحوار ملف
Dim xFileName، xSheetName، xRgStr كسلسلة
خافت xBook ، xWorkBook كمصنف
خافت xSheet كورقة عمل
على خطأ استئناف التالي
Application.DisplayAlerts = خطأ
Application.EnableEvents = خطأ
Application.ScreenUpdating = خطأ
xSheetName = "Sheet1"
xRgStr = "A1: D4"
قم بتعيين xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
مع xFileDlg
إذا كان .Show = -1 ثم
xSelItem =. عناصر محددة. عنصر (1)
تعيين xWorkBook = ThisWorkbook
تعيين xSheet = xWorkBook.Sheets ("ورقة جديدة")
إذا كانت xSheet لا شيء إذن
xWorkBook.Sheets.Add (بعد: = xWorkBook.Worksheets (xWorkBook.Worksheets.count)). الاسم = "ورقة جديدة"
تعيين xSheet = xWorkBook.Sheets ("ورقة جديدة")
إنهاء حالة
xFileName = Dir (xSelItem & "\ *. xlsx"، vbNormal)
إذا كان xFileName = "" قم بالخروج من Sub
القيام به حتى xFileName = ""
قم بتعيين xBook = Workbooks.Open (xSelItem & "\" & xFileName)
قم بتعيين xRg = xBook.Worksheets (xSheetName) .Range (xRgStr)
xRg.Copy xSheet.Range ("A65536"). End (xlUp). Offset (1، 0)
xFileName = Dir ()
xBook. إغلاق
أنشوطة
إنهاء حالة
انتهت ب
قم بتعيين xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = صحيح
xRg.UseStandardWidth = صحيح
Application.DisplayAlerts = صحيح
Application.EnableEvents = صحيح
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا ، شكرا على الكود. يرجى إعلامي كيف يمكنني تضمين اسم ملف Excel الذي تم نسخ نطاق البيانات منه؟ هذه ستكون مساعدة رائعة!

شكرا.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا،

شكرا لك على البرنامج التعليمي.

كيف يمكنني: فقط نسخ الصف في "الورقة 1" بقيم من الصف "الإجمالي" ولصقه باستخدام [اسم الملف] في ورقة العمل الرئيسية المسماة "ورقة جديدة". يمكن أن تختلف ملاحظة الصف الذي يحتوي على الإجمالي في كل ورقة عمل.

فمثلا:
ملف 1: ورقة 1
Col1 ، Col2 ، Colx
1,2,15
النتيجة 10,50

ملف 2: ورقة 1
Col1 ، Col2 ، Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
النتيجة 300,500

MasterFile: "ورقة جديدة":
ملف 1 ، 10 ، 50
ملف 2 ، 300 ، 500
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، هذا يعمل بشكل رائع. هل هناك طريقة للتغيير لسحب القيم فقط وليس الصيغة؟
شكر!!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا تريش ،
يمكن أن تساعدك الكود التالي في حل المشكلة. شكرا لك على تعليقك.

Sub Merge2MultiSheets ()
خافت xRg كمدى
خافت xSelItem كمتغير
خافت xFileDlg كحوار ملف
Dim xFileName، xSheetName، xRgStr كسلسلة
خافت xBook ، xWorkBook كمصنف
خافت xSheet كورقة عمل
على خطأ استئناف التالي
Application.DisplayAlerts = خطأ
Application.EnableEvents = خطأ
Application.ScreenUpdating = خطأ
xSheetName = "Sheet1"
xRgStr = "A1: D4"
قم بتعيين xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
مع xFileDlg
إذا كان .Show = -1 ثم
xSelItem =. عناصر محددة. عنصر (1)
تعيين xWorkBook = ThisWorkbook
تعيين xSheet = xWorkBook.Sheets ("ورقة جديدة")
إذا كانت xSheet لا شيء إذن
xWorkBook.Sheets.Add (بعد: = xWorkBook.Worksheets (xWorkBook.Worksheets.count)). الاسم = "ورقة جديدة"
تعيين xSheet = xWorkBook.Sheets ("ورقة جديدة")
إنهاء حالة
xFileName = Dir (xSelItem & "\ *. xlsx"، vbNormal)
إذا كان xFileName = "" قم بالخروج من Sub
القيام به حتى xFileName = ""
قم بتعيين xBook = Workbooks.Open (xSelItem & "\" & xFileName)
قم بتعيين xRg = xBook.Worksheets (xSheetName) .Range (xRgStr)
xRg.Copy xSheet.Range ("A65536"). End (xlUp). Offset (1، 0)
xFileName = Dir ()
xBook. إغلاق
أنشوطة
إنهاء حالة
انتهت ب
قم بتعيين xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = صحيح
xRg.UseStandardWidth = صحيح
Application.DisplayAlerts = صحيح
Application.EnableEvents = صحيح
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، ما زال يسحب الصيغ ، وليس القيم ، لذا فهو يعطيني الخطأ #REF. أعلم أنه قد يحتاج إلى .PasteSpecial xlPasteValues ​​في مكان ما ، لكن لا يمكنني معرفة المكان. هل يمكنك المساعدة؟ شكرًا!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا شكرا على هذا.


كيف أقوم بتضمين الرمز للتكرار خلال جميع المجلدات والمجلدات الفرعية وتنفيذ النسخة أعلاه؟


شكر!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا - هذا الرمز مثالي لما أحاول تحقيقه.

هل هناك طريقة للتكرار خلال جميع المجلدات والمجلدات الفرعية وإجراء النسخ؟


شكر!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا - يعمل هذا الرمز جيدًا مع أول 565 سطرًا لكل ملف ، ولكن كل الأسطر التي تليها تتداخل مع الملف التالي.
هل هناك طريقة لإصلاح هذا؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
شكرًا لك - كيف سيتمكن المرء من نسخ ولصق (قيم خاصة) من كل ورقة عمل داخل مصنف في أوراق منفصلة داخل ملف رئيسي رئيسي؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
كيف تجعل الشفرة تترك فارغة إذا كانت الخلية فارغة؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
بالنسبة لي ، يتغير اسم علامة التبويب "Sheet1" لكل ملف من ملفاتي. على سبيل المثال ، Tab1 ، Tab2 ، Tab3 ، Tab4 ... كيف يمكنني إعداد حلقة للتشغيل من خلال قائمة في Excel والاستمرار في تغيير اسم "Sheet1" حتى يتم تشغيله من خلال كل شيء؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا Nick ، ​​يمكن أن يساعدك رمز VBA أدناه في حل المشكلة. يرجى المحاولة. الحلقة الفرعية
تم التحديث بواسطة Extendofice 2021/12/31
خافت xRg كمدى
خافت xSelItem كمتغير
خافت xFileDlg كحوار ملف
Dim xFileName، xSheetName، xRgStr كسلسلة
خافت xBook ، xWorkBook كمصنف
خافت xSheet كورقة عمل
خافت xShs كأوراق
خافت xName كسلسلة
خافت xFNum كعدد صحيح
على خطأ استئناف التالي
Application.DisplayAlerts = خطأ
Application.EnableEvents = خطأ
Application.ScreenUpdating = خطأ
قم بتعيين xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item (1)
xFileName = Dir (xSelItem & "\ *. xlsx"، vbNormal)
القيام أثناء xFileName <> ""
قم بتعيين xWorkBook = Workbooks.Open (xSelItem & "\" & xFileName)
تعيين xShs = xWorkBook.Sheets
بالنسبة إلى xFNum = 1 إلى xShs.Count
تعيين xSheet = xShs.Item (xFNum)
xName = xSheet.Name
xName = استبدال (xName، "ورقة""علامة التبويب")" استبدل الورقة بعلامة تبويب
xSheet.Name = xName
التالى
xWorkBook. حفظ
xWorkBook. إغلاق
xFileName = Dir ()
أنشوطة
Application.DisplayAlerts = صحيح
Application.EnableEvents = صحيح
Application.ScreenUpdating = ترو
نهاية الفرعية
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ، أريد رمزًا لنسخ البيانات في 6 مصنفات مختلفة (في مجلد) تحتوي على أوراق مضمنة في كتاب العمل الجديد. في vba
الرجاء مساعدتي آسيا والمحيط الهادئ
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا بارانوشا ،
يمكن أن يدمج البرنامج النصي VBA في المقالة التالية مصنفات متعددة أو أوراق محددة من المصنفات في مصنف رئيسي. يرجى التحقق مما إذا كان يمكن أن يساعد.
كيفية الجمع بين مصنفات متعددة في مصنف رئيسي واحد في Excel؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
Olá bom dia.
Gostei muito dessde código، mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso Imprimir 2.400 relatório de exel que estão em pastas differentes و não estão configuradas corretamente para impressão. Pode me enviar um códgo de VBA que أتمتة essas إعجاب؟ Me ajudaria muito ، obrigada.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا ماريا سواريس ،
يرجى التحقق مما إذا كان رمز VBA في المنشور التالي يمكن أن يساعد.
كيفية طباعة مصنفات متعددة في Excel؟
تم تصغير هذا التعليق بواسطة المشرف على الموقع
السيناريو الخاص بي مشابه ، إلا أن لدي أوراق متعددة في كل ملف ، وكلها بأسماء مختلفة ولكنها متسقة بين الملفات. هل هناك طريقة لتكرار هذا الرمز لنسخ البيانات داخل الملفات ولصق (القيم) إلى أسماء أوراق محددة في المصنف الرئيسي؟ أسماء الأوراق في الرئيسي هي نفسها في الملفات. أريد أن أتفرج من خلالهم. أيضًا ، سيختلف مقدار البيانات في كل ورقة ، لذلك سأحتاج إلى تحديد البيانات في كل ورقة باستخدام شيء مثل هذا:

النطاق ("A1"). حدد
النطاق (التحديد ، التحديد ، النهاية (xlDown)). حدد
النطاق (التحديد ، التحديد ، النهاية (xlToRight)). حدد


أسماء أوراق الملفات هي العطاء ، الخدمات ، التأمين ، السيارة ، المصاريف الأخرى ، إلخ ...

شكرا مقدما.
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا أندرو شاهان ،
يمكن أن يحل رمز VBA التالي مشكلتك. بعد تشغيل الكود وتحديد مجلد ، سيطابق الرمز تلقائيًا ورقة العمل حسب الاسم ويلصق البيانات في ورقة العمل التي تحمل الاسم نفسه في المصنف الرئيسي.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
لا توجد تعليقات منشورة هنا حتى الآن

تواصل معنا

حقوق التأليف والنشر © 2009 - شبكة الاتصالات العالمية.extendoffice.com. | كل الحقوق محفوظة. مشغل بواسطة ExtendOffice. | | خريطة الموقع
Microsoft وشعار Office هما علامتان تجاريتان أو علامتان تجاريتان مسجلتان لشركة Microsoft Corporation في الولايات المتحدة و / أو دول أخرى.
محمي بواسطة Sectigo SSL