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

วิธีการวนซ้ำไฟล์ในไดเร็กทอรีและคัดลอกข้อมูลลงในแผ่นงานหลักใน Excel

สมมติว่ามีสมุดงาน Excel หลายเล่มในโฟลเดอร์และคุณต้องการวนซ้ำไฟล์ Excel เหล่านี้ทั้งหมดและคัดลอกข้อมูลจากช่วงที่ระบุของแผ่นงานชื่อเดียวกันลงในแผ่นงานหลักใน Excel คุณจะทำอย่างไรได้บ้าง? บทความนี้แนะนำวิธีการเพื่อให้บรรลุโดยละเอียด

วนซ้ำไฟล์ในไดเร็กทอรีและคัดลอกข้อมูลลงในแผ่นงานหลักด้วยรหัส VBA


วนซ้ำไฟล์ในไดเร็กทอรีและคัดลอกข้อมูลลงในแผ่นงานหลักด้วยรหัส VBA


หากคุณต้องการคัดลอกข้อมูลที่ระบุในช่วง A1: D4 จากแผ่นงานทั้งหมด 1 แผ่นในโฟลเดอร์หนึ่งไปยังแผ่นงานต้นแบบโปรดทำดังนี้

1. ในสมุดงานคุณจะสร้างแผ่นงานหลักให้กดปุ่ม อื่น ๆ + F11 คีย์เพื่อเปิด Microsoft Visual Basic สำหรับแอปพลิเคชัน หน้าต่าง

2 ใน Microsoft Visual Basic สำหรับแอปพลิเคชัน หน้าต่างคลิก สิ่งที่ใส่เข้าไป > โมดูล. จากนั้นคัดลอกโค้ด VBA ด้านล่างลงในหน้าต่างรหัส

รหัส 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 ของ Sheet1 ทั้งหมดจะถูกคัดลอกไปยังแผ่นงานหลัก และ“แผ่นงานใหม่” คือชื่อของแผ่นงานต้นแบบที่สร้างขึ้นใหม่
2). ไม่ควรเปิดไฟล์ Excel ในโฟลเดอร์เฉพาะ

3 กด F5 กุญแจสำคัญในการเรียกใช้รหัส

4. ในการเปิด หมวดหมู่สินค้า โปรดเลือกโฟลเดอร์ที่มีไฟล์ที่คุณจะวนซ้ำจากนั้นคลิกที่ไฟล์ OK ปุ่ม. ดูภาพหน้าจอ:

จากนั้นแผ่นงานหลักชื่อ "แผ่นงานใหม่" จะถูกสร้างขึ้นที่ส่วนท้ายของสมุดงานปัจจุบัน และข้อมูลในช่วง A1: D4 ของ Sheet1 ทั้งหมดในโฟลเดอร์ที่เลือกจะแสดงรายการภายในแผ่นงาน


บทความที่เกี่ยวข้อง:


เครื่องมือเพิ่มประสิทธิภาพการทำงานในสำนักงานที่ดีที่สุด

Kutools สำหรับ Excel ช่วยแก้ปัญหาส่วนใหญ่ของคุณและเพิ่มผลผลิตของคุณได้ถึง 80%

  • นำมาใช้ใหม่: ใส่อย่างรวดเร็ว สูตรที่ซับซ้อนแผนภูมิ และสิ่งที่คุณเคยใช้มาก่อน เข้ารหัสเซลล์ ด้วยรหัสผ่าน; สร้างรายชื่อผู้รับจดหมาย และส่งอีเมล ...
  • ซุปเปอร์ฟอร์มูล่าบาร์ (แก้ไขข้อความและสูตรหลายบรรทัดได้อย่างง่ายดาย); การอ่านเค้าโครง (อ่านและแก้ไขเซลล์จำนวนมากได้อย่างง่ายดาย); วางลงในช่วงที่กรองแล้ว...
  • ผสานเซลล์ / แถว / คอลัมน์ โดยไม่สูญเสียข้อมูล แยกเนื้อหาของเซลล์ รวมแถว / คอลัมน์ที่ซ้ำกัน... ป้องกันเซลล์ซ้ำ; เปรียบเทียบช่วง...
  • เลือกซ้ำหรือไม่ซ้ำ แถว; เลือกแถวว่าง (เซลล์ทั้งหมดว่างเปล่า); Super Find และ Fuzzy Find ในสมุดงานจำนวนมาก สุ่มเลือก ...
  • สำเนาถูกต้อง หลายเซลล์โดยไม่เปลี่ยนการอ้างอิงสูตร สร้างการอ้างอิงอัตโนมัติ ถึงหลายแผ่น ใส่สัญลักษณ์แสดงหัวข้อย่อย, กล่องกาเครื่องหมายและอื่น ๆ ...
  • แยกข้อความ, เพิ่มข้อความ, ลบตามตำแหน่ง, ลบ Space; สร้างและพิมพ์ผลรวมย่อยของเพจ แปลงระหว่างเนื้อหาของเซลล์และความคิดเห็น...
  • ซุปเปอร์ฟิลเตอร์ (บันทึกและใช้โครงร่างตัวกรองกับแผ่นงานอื่น ๆ ); การเรียงลำดับขั้นสูง ตามเดือน / สัปดาห์ / วันความถี่และอื่น ๆ ตัวกรองพิเศษ โดยตัวหนาตัวเอียง ...
  • รวมสมุดงานและแผ่นงาน; ผสานตารางตามคอลัมน์สำคัญ แยกข้อมูลออกเป็นหลายแผ่น; Batch แปลง xls, xlsx และ PDF...
  • คุณสมบัติที่ทรงพลังมากกว่า 300 รายการ. รองรับ Office / Excel 2007-2019 และ 365 รองรับทุกภาษา ใช้งานง่ายในองค์กรหรือองค์กรของคุณ ทดลองใช้ฟรี 30 วันเต็ม รับประกันคืนเงิน 60 วัน
kte แท็บ 201905

แท็บ Office นำอินเทอร์เฟซแบบแท็บมาที่ Office และทำให้งานของคุณง่ายขึ้นมาก

  • เปิดใช้งานการแก้ไขและอ่านแบบแท็บใน Word, Excel, PowerPoint, ผู้จัดพิมพ์, Access, Visio และโครงการ
  • เปิดและสร้างเอกสารหลายรายการในแท็บใหม่ของหน้าต่างเดียวกันแทนที่จะเป็นในหน้าต่างใหม่
  • เพิ่มผลผลิตของคุณ 50% และลดการคลิกเมาส์หลายร้อยครั้งให้คุณทุกวัน!
ด้านล่าง officetab
จัดเรียงความคิดเห็นโดย
ความคิดเห็น (17)
ยังไม่มีการให้คะแนน เป็นคนแรกที่ให้คะแนน!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ขอบคุณสำหรับรหัส vba! มันทำงานได้อย่างสมบูรณ์แบบ! ต้องการทราบว่ารหัสคืออะไรหากฉันต้องการ PASTE AS VALUE แทน ขอบคุณล่วงหน้า!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี หลี่หลิง
รหัสต่อไปนี้สามารถช่วยคุณแก้ปัญหาได้ ขอบคุณสำหรับความคิดเห็นของคุณ.

รวมย่อย2หลายแผ่น()
Dim xRg เป็นช่วง
Dim xSelItem เป็นตัวแปร
Dim xFileDlg เป็น FileDialog
Dim xFileName, xSheetName, xRgStr เป็นสตริง
Dim xBook, xWorkBook เป็นสมุดงาน
Dim xSheet เป็นแผ่นงาน
เกี่ยวกับข้อผิดพลาดต่อไป
Application.DisplayAlerts = เท็จ
Application.EnableEvents = เท็จ
Application.ScreenUpdating = เท็จ
xSheetName = "แผ่นงาน 1"
xRgStr = "A1:D4"
ตั้งค่า xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
ด้วย xFileDlg
ถ้า .Show = -1 แล้ว
xSelItem = .SelectedItems.Item(1)
ตั้งค่า xWorkBook = ThisWorkbook
ตั้งค่า xSheet = xWorkBook.Sheets("แผ่นงานใหม่")
ถ้า xSheet ไม่มีอะไรเลย
xWorkBook.Sheets.Add(หลัง:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "แผ่นงานใหม่"
ตั้งค่า xSheet = xWorkBook.Sheets("แผ่นงานใหม่")
End If
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 = ไดร์()
xBook.ปิด
ห่วง
End If
จบด้วย
ตั้งค่า xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = จริง
xRg.UseStandardWidth = จริง
Application.DisplayAlerts = จริง
Application.EnableEvents = จริง
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ขอบคุณสำหรับรหัส โปรดแจ้งให้เราทราบว่าฉันจะรวมชื่อไฟล์ Excel ที่คัดลอกช่วงข้อมูลได้อย่างไร นี่จะช่วยได้มาก!

ขอขอบคุณ.
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี,

ขอบคุณสำหรับการกวดวิชา

ฉันจะ: คัดลอกเฉพาะแถวใน "Sheet1" ด้วยค่าจากแถว "total" และวางด้วย [filename] ในเวิร์กชีตหลักที่ชื่อว่า "New Sheet" การสังเกตแถวด้วยผลรวมอาจแตกต่างกันในแต่ละเวิร์กชีต

ตัวอย่างเช่น:
ไฟล์1: Sheet1
Col1,Col2,Colx
1,2,15
ผลลัพธ์10,50

ไฟล์2: Sheet1
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
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี มันใช้งานได้ดี มีวิธีการเปลี่ยนแปลงเพียงแค่ดึงค่าและไม่ใช่สูตรหรือไม่?
ขอบคุณ !!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี Trish
รหัสต่อไปนี้สามารถช่วยคุณแก้ปัญหาได้ ขอบคุณสำหรับความคิดเห็นของคุณ.

รวมย่อย2หลายแผ่น()
Dim xRg เป็นช่วง
Dim xSelItem เป็นตัวแปร
Dim xFileDlg เป็น FileDialog
Dim xFileName, xSheetName, xRgStr เป็นสตริง
Dim xBook, xWorkBook เป็นสมุดงาน
Dim xSheet เป็นแผ่นงาน
เกี่ยวกับข้อผิดพลาดต่อไป
Application.DisplayAlerts = เท็จ
Application.EnableEvents = เท็จ
Application.ScreenUpdating = เท็จ
xSheetName = "แผ่นงาน 1"
xRgStr = "A1:D4"
ตั้งค่า xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
ด้วย xFileDlg
ถ้า .Show = -1 แล้ว
xSelItem = .SelectedItems.Item(1)
ตั้งค่า xWorkBook = ThisWorkbook
ตั้งค่า xSheet = xWorkBook.Sheets("แผ่นงานใหม่")
ถ้า xSheet ไม่มีอะไรเลย
xWorkBook.Sheets.Add(หลัง:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "แผ่นงานใหม่"
ตั้งค่า xSheet = xWorkBook.Sheets("แผ่นงานใหม่")
End If
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 = ไดร์()
xBook.ปิด
ห่วง
End If
จบด้วย
ตั้งค่า 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 ด้านล่างสามารถช่วยคุณแก้ปัญหาได้ ได้โปรดลองดู ย่อย LoopThroughFileRename()
'อัปเดตโดย Extendofice 2021/12/31
Dim xRg เป็นช่วง
Dim xSelItem เป็นตัวแปร
Dim xFileDlg เป็น FileDialog
Dim xFileName, xSheetName, xRgStr เป็นสตริง
Dim xBook, xWorkBook เป็นสมุดงาน
Dim xSheet เป็นแผ่นงาน
Dim xShs เป็นชีต
Dim xName เป็นสตริง
Dim 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, "แผ่น""แถบ") 'แทนที่แผ่นงานด้วย Tab
xSheet.Name = xชื่อ
ต่อไป
xWorkBook บันทึก
xWorkBook.ปิด
xFileName = ไดร์()
ห่วง
Application.DisplayAlerts = จริง
Application.EnableEvents = จริง
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีฉันต้องการรหัสเพื่อคัดลอกข้อมูลใน 6 สมุดงานที่แตกต่างกัน (ในโฟลเดอร์) ซึ่งมีแผ่นงานรวมอยู่ในสมุดงานใหม่ ใน vba
ได้โปรดช่วยฉันด้วย
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีค่ะ คุณปารนุช
สคริปต์ VBA ในบทความต่อไปนี้สามารถรวมสมุดงานหลายแผ่นหรือแผ่นงานที่ระบุในสมุดงานหลัก โปรดตรวจสอบว่าสามารถช่วยได้หรือไม่
วิธีการรวมสมุดงานหลายเล่มไว้ในสมุดงานหลักเดียวใน Excel?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
โอลา บอม เดีย
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir
Preciso imprimir 2.400 เกี่ยวข้องกับ exel que estão em pastas diferentes e não estão configuradas corretamente para impressão. ทำให้ฉันอิจฉา um códgo de VBA que automatize essas impressões ? ฉัน อจูดาเรีย มุยโต, obrigada
มีความคิดเห็นยังไม่มีการโพสต์ที่นี่
แสดงความคิดเห็นของคุณ
โพสต์ในฐานะแขก
×
ให้คะแนนโพสต์นี้:
0   ตัวอักษร
สถานที่แนะนำ