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

Làm cách nào để lặp qua các tệp trong một thư mục và sao chép dữ liệu vào một trang tính chính trong Excel?

Giả sử có nhiều sổ làm việc Excel trong một thư mục và bạn muốn lặp lại tất cả các tệp Excel này và sao chép dữ liệu từ dải bảng tính cùng tên được chỉ định vào một trang tính chính trong Excel, bạn có thể làm gì? Bài viết này giới thiệu một phương pháp để đạt được nó một cách chi tiết.

Lặp qua các tệp trong một thư mục và sao chép dữ liệu vào một trang tính chính với mã VBA


Lặp qua các tệp trong một thư mục và sao chép dữ liệu vào một trang tính chính với mã VBA

Nếu bạn muốn sao chép dữ liệu được chỉ định trong phạm vi A1: D4 từ tất cả sheet1 của sổ làm việc trong một thư mục nhất định vào một trang tính chính, vui lòng thực hiện như sau.

1. Trong sổ làm việc, bạn sẽ tạo một trang tính chính, hãy nhấn Khác + F11 phím để mở Microsoft Visual Basic cho các ứng dụng cửa sổ.

2. bên trong Microsoft Visual Basic cho các ứng dụng cửa sổ, nhấp Chèn > Mô-đun. Sau đó sao chép mã VBA bên dưới vào cửa sổ mã.

Mã VBA: lặp qua các tệp trong một thư mục và sao chép dữ liệu vào một trang tính chính

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

Chú thích:

1). Trong mã, “A1: D4"Và"Sheet1”Nghĩa là dữ liệu trong phạm vi A1: D4 của tất cả Trang tính1 sẽ được sao chép vào trang tính chính. Và “Trang tính mới”Là tên của trang tính chính mới được tạo.
2). Các tệp Excel trong thư mục cụ thể sẽ không mở.

3. Nhấn nút F5 phím để chạy mã.

4. Trong phần mở đầu Xem cửa sổ, vui lòng chọn thư mục chứa các tệp bạn sẽ lặp lại, sau đó nhấp vào OK cái nút. Xem ảnh chụp màn hình:

Sau đó, một trang tính chính có tên “Trang tính mới” được tạo ở cuối sổ làm việc hiện tại. Và dữ liệu trong phạm vi A1: D4 của tất cả Sheet1 trong thư mục đã chọn được liệt kê bên trong trang tính.


Các bài liên quan:


Các công cụ năng suất văn phòng tốt nhất

Kutools cho Excel giải quyết hầu hết các vấn đề của bạn và tăng 80% năng suất của bạn

  • Tái sử dụng: Chèn nhanh công thức phức tạp, biểu đồ và bất cứ thứ gì bạn đã sử dụng trước đây; Mã hóa ô với mật khẩu; Tạo danh sách gửi thư và gửi email ...
  • Thanh siêu công thức (dễ dàng chỉnh sửa nhiều dòng văn bản và công thức); Bố cục đọc (dễ dàng đọc và chỉnh sửa số lượng ô lớn); Dán vào Dải ô đã Lọchữu ích. Cảm ơn !
  • Hợp nhất các ô / hàng / cột mà không làm mất dữ liệu; Nội dung phân chia ô; Kết hợp các hàng / cột trùng lặp... Ngăn chặn các ô trùng lặp; So sánh các dãyhữu ích. Cảm ơn !
  • Chọn trùng lặp hoặc duy nhất Hàng; Chọn hàng trống (tất cả các ô đều trống); Tìm siêu và Tìm mờ trong Nhiều Sổ làm việc; Chọn ngẫu nhiên ...
  • Bản sao chính xác Nhiều ô mà không thay đổi tham chiếu công thức; Tự động tạo tài liệu tham khảo sang Nhiều Trang tính; Chèn Bullets, Hộp kiểm và hơn thế nữa ...
  • Trích xuất văn bản, Thêm Văn bản, Xóa theo Vị trí, Xóa không gian; Tạo và In Tổng số phân trang; Chuyển đổi giữa nội dung ô và nhận xéthữu ích. Cảm ơn !
  • Siêu lọc (lưu và áp dụng các lược đồ lọc cho các trang tính khác); Sắp xếp nâng cao theo tháng / tuần / ngày, tần suất và hơn thế nữa; Bộ lọc đặc biệt bằng cách in đậm, in nghiêng ...
  • Kết hợp Workbook và WorkSheets; Hợp nhất các bảng dựa trên các cột chính; Chia dữ liệu thành nhiều trang tính; Chuyển đổi hàng loạt xls, xlsx và PDFhữu ích. Cảm ơn !
  • Hơn 300 tính năng mạnh mẽ. Hỗ trợ Office / Excel 2007-2021 và 365. Hỗ trợ tất cả các ngôn ngữ. Dễ dàng triển khai trong doanh nghiệp hoặc tổ chức của bạn. Đầy đủ tính năng Dùng thử miễn phí 30 ngày. Bảo đảm hoàn lại tiền trong 60 ngày.
tab kte 201905

Tab Office mang lại giao diện Tab cho Office và giúp công việc của bạn trở nên dễ dàng hơn nhiều

  • Cho phép chỉnh sửa và đọc theo thẻ trong Word, Excel, PowerPoint, Publisher, Access, Visio và Project.
  • Mở và tạo nhiều tài liệu trong các tab mới của cùng một cửa sổ, thay vì trong các cửa sổ mới.
  • Tăng 50% năng suất của bạn và giảm hàng trăm cú nhấp chuột cho bạn mỗi ngày!
officetab dưới cùng
Nhận xét (20)
Chưa có xếp hạng. Hãy là người đầu tiên xếp hạng!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
cảm ơn bạn vì mã vba! Nó hoạt động hoàn hảo! Thay vào đó, tôi có muốn biết mã là gì nếu tôi cần TRẢ LỜI NHƯ GIÁ TRỊ không? Thx trước!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào Lai Ling,
Đoạn mã sau có thể giúp bạn giải quyết vấn đề. Cảm ơn bình luận của bạn.

Sub Merge2MultiSheets ()
Dim xRg theo phạm vi
Dim xSelItem dưới dạng biến thể
Làm mờ xFileDlg dưới dạng FileDialog
Làm mờ xFileName, xSheetName, xRgStr dưới dạng chuỗi
Làm mờ xBook, xWorkBook như Workbook
Làm mờ xSheet dưới dạng trang tính
On Error Resume Next
Application.DisplayAlerts = Sai
Application.EnableEvents = Sai
Application.ScreenUpdating = Sai
xSheetName = "Trang 1"
xRgStr = "A1: D4"
Đặt xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
Với xFileDlg
Nếu .Show = -1 Thì
xSelItem = .SelectedItems.Item (1)
Đặt xWorkBook = ThisWorkbook
Đặt xSheet = xWorkBook.Sheets ("Trang tính mới")
Nếu xSheet không có gì thì
xWorkBook.Sheets.Add (sau: = xWorkBook.Worksheets (xWorkBook.Worksheets.count)). Name = "Trang tính mới"
Đặt xSheet = xWorkBook.Sheets ("Trang tính mới")
Cuối Nếu
xFileName = Dir (xSelItem & "\ *. xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Đặt xBook = Workbooks.Open (xSelItem & "\" & xFileName)
Đặt xRg = xBook.Worksheets (xSheetName) .Range (xRgStr)
xRg.Copy xSheet.Range ("A65536"). End (xlUp) .Offset (1, 0)
xFileName = Dir ()
xBook.Close
Vòng lặp
Cuối Nếu
Kết thúc với
Đặt xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = Đúng
Ứng dụng.DisplayAlerts = Đúng
Ứng dụng.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào, cảm ơn vì mã. Vui lòng cho tôi biết làm cách nào tôi có thể bao gồm tên tệp Excel mà từ đó phạm vi dữ liệu đã được sao chép? Đây sẽ là một sự trợ giúp tuyệt vời!

Cảm ơn bạn.
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Chào bạn,

Cám ơn chuyến về viếng thăm.

Tôi sẽ làm như thế nào: Chỉ sao chép hàng trong "Trang tính1" với các giá trị từ hàng "tổng" và dán với [tên tệp] trong trang tính chính có tên "Trang tính mới". Lưu ý hàng với Tổng có thể khác nhau trong mỗi trang tính.

Ví dụ:
Tệp1: Trang tính1
Col1, Col2, Colx
1,2,15
Kết quả, 10,50

Tệp2: Trang tính1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Kết quả, 300,500

MasterFile: "Trang tính mới":
tệp1, 10, 50
tệp2, 300, 500
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào, Điều này hoạt động tốt. Có cách nào để thay đổi để chỉ kéo qua các giá trị chứ không phải công thức không?
Cảm ơn!!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Chào Trish,
Đoạn mã sau có thể giúp bạn giải quyết vấn đề. Cảm ơn bình luận của bạn.

Sub Merge2MultiSheets ()
Dim xRg theo phạm vi
Dim xSelItem dưới dạng biến thể
Làm mờ xFileDlg dưới dạng FileDialog
Làm mờ xFileName, xSheetName, xRgStr dưới dạng chuỗi
Làm mờ xBook, xWorkBook như Workbook
Làm mờ xSheet dưới dạng trang tính
On Error Resume Next
Application.DisplayAlerts = Sai
Application.EnableEvents = Sai
Application.ScreenUpdating = Sai
xSheetName = "Trang 1"
xRgStr = "A1: D4"
Đặt xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
Với xFileDlg
Nếu .Show = -1 Thì
xSelItem = .SelectedItems.Item (1)
Đặt xWorkBook = ThisWorkbook
Đặt xSheet = xWorkBook.Sheets ("Trang tính mới")
Nếu xSheet không có gì thì
xWorkBook.Sheets.Add (sau: = xWorkBook.Worksheets (xWorkBook.Worksheets.count)). Name = "Trang tính mới"
Đặt xSheet = xWorkBook.Sheets ("Trang tính mới")
Cuối Nếu
xFileName = Dir (xSelItem & "\ *. xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Đặt xBook = Workbooks.Open (xSelItem & "\" & xFileName)
Đặt xRg = xBook.Worksheets (xSheetName) .Range (xRgStr)
xRg.Copy xSheet.Range ("A65536"). End (xlUp) .Offset (1, 0)
xFileName = Dir ()
xBook.Close
Vòng lặp
Cuối Nếu
Kết thúc với
Đặt xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = Đúng
Ứng dụng.DisplayAlerts = Đúng
Ứng dụng.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào, nó vẫn đang kéo các công thức chứ không phải các giá trị, vì vậy nó gây cho tôi lỗi #REF. Tôi biết nó có thể cần một xlPasteValues ​​.PasteSpecial ở đâu đó, nhưng tôi không thể tìm ra ở đâu. Bạn có thể giúp? Thanks!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào Cảm ơn vì điều này.


Làm cách nào để bao gồm mã để lặp qua tất cả các thư mục và thư mục con và thực hiện sao chép ở trên?


Cảm ơn!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào - Mã này hoàn hảo cho những gì tôi đang cố gắng đạt được.

Có cách nào để lặp qua tất cả các thư mục và thư mục con và thực hiện sao chép không?


Cảm ơn!
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào - Mã này hoạt động rất tốt cho 565 dòng đầu tiên cho mọi tệp, nhưng tất cả các dòng sau đó bị chồng lên bởi tệp tiếp theo.
Có cách nào để sửa lỗi này?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Cảm ơn bạn - làm cách nào để có thể sao chép và dán (các giá trị đặc biệt) từ mỗi trang tính trong sổ làm việc thành các trang tính riêng biệt trong một tệp Chính?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Làm thế nào để bạn thực hiện để mã để trống nếu ô trống?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
đối với tôi, tên tab "Sheet1" thay đổi cho từng tệp của tôi. Ví dụ: Tab1, Tab2, Tab3, Tab4 ... Làm cách nào để thiết lập một vòng lặp để chạy qua một danh sách trong excel và tiếp tục thay đổi tên "Sheet1" cho đến khi nó chạy qua mọi thứ?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào Nick, Đoạn mã VBA dưới đây có thể giúp bạn giải quyết vấn đề. Xin vui lòng có một thử. Sub LoopThroughFileRename ()
'Được cập nhật bởi Extendofice 2021/12/31
Dim xRg theo phạm vi
Dim xSelItem dưới dạng biến thể
Làm mờ xFileDlg dưới dạng FileDialog
Làm mờ xFileName, xSheetName, xRgStr dưới dạng chuỗi
Làm mờ xBook, xWorkBook như Workbook
Làm mờ xSheet dưới dạng trang tính
Làm mờ xShs dưới dạng trang tính
Dim xName dưới dạng chuỗi
Dim xFNum dưới dạng số nguyên
On Error Resume Next
Application.DisplayAlerts = Sai
Application.EnableEvents = Sai
Application.ScreenUpdating = Sai
Đặt xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item (1)
xFileName = Dir (xSelItem & "\ *. xlsx", vbNormal)
Làm trong khi xFileName <> ""
Đặt xWorkBook = Workbooks.Open (xSelItem & "\" & xFileName)
Đặt xShs = xWorkBook.Sheets
Đối với xFNum = 1 Đến xShs.Count
Đặt xSheet = xShs.Item (xFNum)
xName = xSheet.Name
xName = Replace (xName, "Bảng""Tab") 'Thay thế Trang tính bằng Tab
xSheet.Name = xName
Sau
xWorkBook.Save
xWorkBook.Close
xFileName = Dir ()
Vòng lặp
Ứng dụng.DisplayAlerts = Đúng
Ứng dụng.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào, tôi muốn có mã để sao chép dữ liệu trong 6 sổ làm việc khác nhau (trong một thư mục) trong đó có các trang tính được đưa vào SÁCH CÔNG VIỆC MỚI. trong vba
làm ơn giúp tôi với.
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào Paranusha,
Tập lệnh VBA trong bài viết sau có thể kết hợp nhiều sổ làm việc hoặc trang tính được chỉ định của sổ làm việc vào một sổ làm việc chính. Vui lòng kiểm tra nếu nó có thể giúp đỡ.
Làm thế nào để kết hợp nhiều sổ làm việc thành một sổ làm việc chính trong Excel?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Olá bom dia.
Món tráng miệng Gostei muito código, mas não tôi ajudou com os relatórios que eu Preiso impreimir.
Preciso printmir 2.400 relatório de exel que estão em pastas diferentes e não estão configuradas corretamente para Ấn tượng. Pode me enviar um códgo de VBA que tự động hóa essas ấn tượng? Tôi ajudaria muito, obrigada.
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Chào Maria Soares,
Vui lòng kiểm tra xem mã VBA trong bài viết sau có giúp được gì không.
Làm cách nào để in nhiều sổ làm việc trong Excel?
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Kịch bản của tôi cũng tương tự, ngoại trừ tôi có nhiều trang tính trong mỗi tệp, tất cả đều có tên khác nhau nhưng nhất quán giữa các tệp. Có cách nào để Lặp lại mã này để sao chép dữ liệu trong tệp và dán (giá trị) vào tên trang tính cụ thể trong sổ làm việc chính không? Tên trang tính trong bản gốc giống như trong tệp. Tôi muốn lặp qua chúng. Ngoài ra, lượng dữ liệu trong mỗi trang tính sẽ khác nhau, vì vậy tôi sẽ cần chọn dữ liệu trong mỗi trang tính bằng cách sử dụng một số thứ như sau:

Phạm vi ("A1"). Chọn
Phạm vi (Lựa chọn, Lựa chọn.End (xlDown)). Chọn
Phạm vi (Lựa chọn, Lựa chọn.End (xlToRight)). Chọn


Tên trang tính là Cho, Dịch vụ, Bảo hiểm, Xe hơi, Chi phí khác, v.v ...

Cảm ơn trước.
Nhận xét này đã được giảm thiểu bởi người điều hành trên trang web
Xin chào Andrew Shahan,
Mã VBA sau đây có thể giải quyết vấn đề của bạn. Sau khi chạy mã và chọn một thư mục, mã sẽ tự động khớp trang tính theo tên và dán dữ liệu vào trang tính cùng tên trong sổ làm việc chính.
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
Không có bình luận nào được đăng ở đây
Để lại ý kiến ​​của bạn
Đăng với tư cách khách
×
Đánh giá bài viết này:
0   Nhân vật
Các vị trí được đề xuất

Kết nối với chúng tôi

Bản quyền © 2009 - www.extendoffice.com. | Đã đăng ký Bản quyền. cung cấp bởi ExtendOffice. | BẢN ĐỒ CHI NHÁNH
Microsoft và logo Office là các nhãn hiệu hoặc nhãn hiệu đã đăng ký của Microsoft Corporation tại Hoa Kỳ và / hoặc các quốc gia khác.
Được bảo vệ bởi Sectigo SSL