Gộp nhiều file nối tiếp nhau mà không cần mở hộp chọn

rdxls · 13/1/19

Yêu cầu:
- Tư tìm file dựa vào đặc điểm tên của file
- Ghi nối tiếp nhau

Trong file đính kèm, em có 2 đoạn code:
- Code GopFileExcel: đúng với yêu cầu là ghi nối tiếp, nhưng sử dụng hộp chọn
- Code ImportSheets: đúng với yêu cầu là tự tìm file, nhưng không ghi nối tiếp

Làm sao để kết hợp 2 code này lại để có thể được như yêu cầu ạ. Xin giúp đỡ.

batman1 · 13/1/19

Tức bạn muốn làm y như code gộp nhưng không hiện hộp thoại mà code tự lấy tất cả các tập tin dạng XLSX?
Nếu thế thì vấn đề cụ thể này của bạn có thể giải quyết như sau. Tôi chả sửa, cũng chả làm cách khác mà chỉ gộp 2 code thành một thôi. Chẳng qua là lấy gương mặt thiên thần của cô A, lấy đường cong của cô B, và lấy sự dịu dàng của cô C để tạo cô D hoàn hảo. Thế thôi.

Mã:

Sub Gop()
Dim x As Integer, directory As String, fileName As String, wb As Workbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    directory = (ThisWorkbook.Path & "\")
    fileName = Dir(directory & "*.xlsx")
    
    Do While fileName <> ""
        Set wb = Workbooks.Open(fileName)
            
        If x = 0 Then
            wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1")
        Else
            lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count
            wb.Sheets(1).UsedRange.Offset(1).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
        End If
        
        wb.Close False
        x = x + 1
        fileName = Dir()
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

rdxls · 13/1/19

batman1 đã viết:
Tức bạn muốn làm y như code gộp nhưng không hiện hộp thoại mà code tự lấy tất cả các tập tin dạng XLSX?
Nếu thế thì vấn đề cụ thể này của bạn có thể giải quyết như sau. Tôi chả sửa, cũng chả làm cách khác mà chỉ gộp 2 code thành một thôi. Chẳng qua là lấy gương mặt thiên thần của cô A, lấy đường cong của cô B, và lấy sự dịu dàng của cô C để tạo cô D hoàn hảo. Thế thôi.

Vẫn chưa thấy được cô D ạ. Báo lỗi không tìm thấy cô A, B, C. Anh xem lại giúp em ạ.

Hoàng Nhật Phương · 13/1/19

rdxls đã viết:
Vẫn chưa thấy được cô D ạ. Báo lỗi không tìm thấy cô A, B, C. Anh xem lại giúp em ạ.

Bạn thử sửa dòng:

Set wb = Workbooks.Open(fileName)

Thành:

Set wb = Workbooks.Open(directory & fileName)

Và đề phòng lỗi "Variable not defined" xảy ra thì bạn khai báo thêm biến "lr " :
Sau dòng:

Dim x As Integer, directory As String, fileName As String, wb As Workbook

Thêm:

Dim lr As Long

rdxls · 13/1/19

Nguyễn Hoàng Oanh Thơ đã viết:
Bạn sửa dòng:
Set wb = Workbooks.Open(fileName)
Thành:
Set wb = Workbooks.Open(directory & fileName)

Tuyệt vời. Đã chạy được rồi ạ. Cảm ơn rất nhiều ạ.

tam888 · 14/1/19

batman1 đã viết:
Tức bạn muốn làm y như code gộp nhưng không hiện hộp thoại mà code tự lấy tất cả các tập tin dạng XLSX?
Nếu thế thì vấn đề cụ thể này của bạn có thể giải quyết như sau. Tôi chả sửa, cũng chả làm cách khác mà chỉ gộp 2 code thành một thôi. Chẳng qua là lấy gương mặt thiên thần của cô A, lấy đường cong của cô B, và lấy sự dịu dàng của cô C để tạo cô D hoàn hảo. Thế thôi.

Mã:

Sub Gop() Dim x As Integer, directory As String, fileName As String, wb As Workbook Application.ScreenUpdating = False Application.DisplayAlerts = False directory = (ThisWorkbook.Path & "\") fileName = Dir(directory & "*.xlsx") Do While fileName <> "" Set wb = Workbooks.Open(fileName) If x = 0 Then wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1") Else lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count wb.Sheets(1).UsedRange.Offset(1).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1) End If wb.Close False x = x + 1 fileName = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

Kiểu này bác muốn 1 nhát chém nhiều, lầm còn hơn bỏ sót đây, đúng ý kiến chủ topic (ghép đại nhiều file)

quick87 · 14/1/19

Nguyễn Hoàng Oanh Thơ đã viết:
Bạn thử sửa dòng:

Thành:

Và đề phòng lỗi "Variable not defined" xảy ra thì bạn khai báo thêm biến "lr " :
Sau dòng:

Thêm:

Nếu có thể được, nhờ @Nguyễn Hoàng Oanh Thơ và GPE viết giúp cho xin thêm 1 cột tên file phía sau cùng giúp nhé.
Cảm ơn GPE nhiều !

Hoàng Nhật Phương · 14/1/19

Bạn thử code sau xem sao ạ:

Mã:

Sub Gop_2()
    
    Dim x As Integer, directory As String, fileName As String, wb As Workbook
    Dim ws As Worksheet, lc As Long, lr As Long, lr2 As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    directory = (ThisWorkbook.Path & "\")
    fileName = Dir(directory & "*.xlsx")
    Set ws = ThisWorkbook.Sheets(1)
    Do While fileName <> ""
        Set wb = Workbooks.Open(directory & fileName)
        If x = 0 Then
            wb.Sheets(1).UsedRange.Copy ws.Range("A1")
                lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                lr = ws.UsedRange.Rows.Count
            If ws.Cells(1, lc).Value <> "Tên file" Then
                ws.Cells(1, lc + 1).Value = "Tên file"
                ws.Cells(2, lc + 1).Resize(lr - 1).Value = fileName
            End If
        Else
            lr = ws.UsedRange.Rows.Count
            wb.Sheets(1).UsedRange.Offset(1).Copy ws.Range("A" & lr + 1)
            lr2 = wb.Sheets(1).UsedRange.Rows.Count
            lc = ws.Cells(lr + 1, ws.Columns.Count).End(xlToLeft).Column
            ws.Cells(lr + 1, lc + 1).Resize(lr2 - 1).Value = fileName
        End If
        wb.Close False
        x = x + 1
        fileName = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Gộp nhiều file nối tiếp nhau mà không cần mở hộp chọn

rdxls

Thành viên mới

File đính kèm

batman1

Thành viên gạo cội

rdxls

Thành viên mới

File đính kèm

Hoàng Nhật Phương

Thành viên gắn bó

rdxls

Thành viên mới

tam888

Thành viên tích cực

quick87

(/ội...

Hoàng Nhật Phương

Thành viên gắn bó

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng