Nhờ giúp code copy nhiều file excel trong thư mục thành 1 file (1 người xem)

thanhduc_iit · 18/4/14

Chào các bác,
Hiện em có 1 vấn đề nhờ các bác giúp đỡ -=.,,

Em có 1 thư mục chứa khoảng 100 file excel, giờ em muốn gom 100 file đó lại thành 1 file duy nhất. Làm bằng tay thì khá tốn thời gian. Nên em nhờ các bác giúp đỡ viết code để vba làm tự động @$@!^%

E cũng đã tham khảo nhiều topic nhưng chưa giải quyết được.

Mã:

Sub TongHop_Click()
Application.ScreenUpdating = False
MyFile = Array([B]"aa0001a", "aa0002a", "aa0003a"[/B]) 
MyPath = ActiveWorkbook.Path
For i = 0 To UBound(MyFile)
    Workbooks.Open Filename:=MyPath & "\" & MyFile(i) & ".xls"
    Workbooks(MyFile(i)).Sheets(1).Range([A2], [ab65000].End(xlUp)).Copy Workbooks("Tong Hop").Sheets("Sheet1").[A65536].End(xlUp).Offset(1)
    Windows(MyFile(i) & ".xls").Close
Next
Application.ScreenUpdating = True
End Sub

Vấn đề code ở trên là tên file phải set cứng, có cách nào tự động lấy tên file gán vào luôn được k ạ?

Hau151978 · 18/4/14

thanhduc_iit đã viết:
Chào các bác,
Hiện em có 1 vấn đề nhờ các bác giúp đỡ
Em có 1 thư mục chứa khoảng 100 file excel, giờ em muốn gom 100 file đó lại thành 1 file duy nhất. Làm bằng tay thì khá tốn thời gian. Nên em nhờ các bác giúp đỡ viết code để vba làm tự động
E cũng đã tham khảo nhiều topic nhưng chưa giải quyết được.
Vấn đề code ở trên là tên file phải set cứng, có cách nào tự động lấy tên file gán vào luôn được k ạ?

Cách này có thể giúp được bạn không: copy tất cả các file vào chung 1 folder. Bấm Ctrl-A để chọn tất cả, bấm F2 để đổi tên, ví dụ a.xls. Tất cả các file sẽ đổi tên thành a.xls, a (1).xls, a (2).xls..... Trong code của bạn chỉ cần lưu sẵn những tên file này.

Hai Lúa Miền Tây · 18/4/14

thanhduc_iit đã viết:
Chào các bác,
Hiện em có 1 vấn đề nhờ các bác giúp đỡ
Em có 1 thư mục chứa khoảng 100 file excel, giờ em muốn gom 100 file đó lại thành 1 file duy nhất. Làm bằng tay thì khá tốn thời gian. Nên em nhờ các bác giúp đỡ viết code để vba làm tự động
E cũng đã tham khảo nhiều topic nhưng chưa giải quyết được.

Mã:

Sub TongHop_Click() Application.ScreenUpdating = False MyFile = Array([B]"aa0001a", "aa0002a", "aa0003a"[/B]) MyPath = ActiveWorkbook.Path For i = 0 To UBound(MyFile) Workbooks.Open Filename:=MyPath & "\" & MyFile(i) & ".xls" Workbooks(MyFile(i)).Sheets(1).Range([A2], [ab65000].End(xlUp)).Copy Workbooks("Tong Hop").Sheets("Sheet1").[A65536].End(xlUp).Offset(1) Windows(MyFile(i) & ".xls").Close Next Application.ScreenUpdating = True End Sub

Vấn đề code ở trên là tên file phải set cứng, có cách nào tự động lấy tên file gán vào luôn được k ạ?

Thử code lấy đường dẫn của file như sau:

Mã:

Sub test()
    Dim strFileName As Variant
    Dim i As Integer
    strFileName = Application.GetOpenFilename("Excel Files (*.xls), *.xls", _
                  Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        For i = LBound(strFileName) To UBound(strFileName)
            MsgBox strFileName(i)
            'code copy cua ban vao day
        Next i
    End If
End Sub

VetMini · 18/4/14

Lưu ý chủ thớt:
Code của bạn dùng giới hạn sheet ở 65K's dòng, tức là code dùng cho Excel 2003.
Nếu dùng trong môi trường này, thì có thể nói code thiếu phần chuyển sang sheet mới nếu sheet hiện tại đã đầy.

thanhduc_iit · 18/4/14

Trước tiên cảm ơn các bác đã gúp đỡ.
Em đã làm theo code của bác Hai Lúa Miền Tây, nhưng báo lỗi out of range @#!^%

Sub test() Dim strFileName As Variant
Dim i As Integer
strFileName = Application.GetOpenFilename("Excel Files (*.xls), *.xls", _
Title:="Select files", MultiSelect:=True)
If IsArray(strFileName) Then
For i = LBound(strFileName) To UBound(strFileName)
MsgBox strFileName(i)
'code copy cua ban vao day
Workbooks(strFileName(i)).Sheets(1).Range([A2], [ab65000].End(xlUp)).Copy Workbooks("Tong Hop").Sheets("Sheet1").[A65536].End(xlUp).Offset(1)
Windows(strFileName(i) & ".xls").Close
Next i
Application.ScreenUpdating = True
End If
End Sub

Mong các bác hướng dẫn thêm ạ }}}}}

Mỗi file excel em cần lấy dữ liệu từ cột A2 đến AB, dòng thứ 2 đến hết vùng chứa dữ liệu ;;;;;;;;;;;

Hai Lúa Miền Tây · 18/4/14

thanhduc_iit đã viết:
Trước tiên cảm ơn các bác đã gúp đỡ.
Em đã làm theo code của bác Hai Lúa Miền Tây, nhưng báo lỗi out of range

Mong các bác hướng dẫn thêm ạ
Mỗi file excel em cần lấy dữ liệu từ cột A2 đến AB, dòng thứ 2 đến hết vùng chứa dữ liệu

Đây là code lấy dữ liệu của tất cả các sheet của các file bạn chọn. Bạn test và chỉnh lại theo yêu cầu riêng của bạn.

Mã:

Sub Gop()
    Dim strFileName As Variant
    Dim myBook As Workbook
    Dim mySheet As Worksheet
    Dim i As Integer
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
                With ThisWorkbook.Sheets(1)
                    mySheet.Range("A1").CurrentRegion.Copy .Range("C65536").End(xlUp).Offset(1, 0)
                    .Range(.Range("A65536").End(xlUp).Offset(1, 0), _
                            .Range("C65536").End(xlUp).Offset(0, -2)).Value = myBook.Name
                    .Range(.Range("B65536").End(xlUp).Offset(1, 0), _
                            .Range("C65536").End(xlUp).Offset(0, -1)).Value = mySheet.Name
                End With
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

thanhduc_iit · 23/4/14

Em đã sử dụng code của bác Hai Lúa:

Mã:

Sub Gop()    
    Dim strFileName As Variant
    Dim myBook As Workbook
    Dim mySheet As Worksheet
    Dim i As Integer
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
                With ThisWorkbook.Sheets(1)
                    mySheet.Range("A1").CurrentRegion.Copy .Range("A65536").End(xlUp).Offset(1, 0)
                End With
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

Nhưng chưa theo đúng yêu cầu, bác có thể nào sửa đoạn code trên lại theo yêu cầu: Chỉ copy từ dòng A2 được k?

VetMini · 23/4/14

thanhduc_iit đã viết:
Em đã sử dụng code của bác Hai Lúa:

Mã:

Sub Gop() ... End Sub

Nhưng chưa theo đúng yêu cầu, bác có thể nào sửa đoạn code trên lại theo yêu cầu: Chỉ copy từ dòng A2 được k?

Chưa theo đúng yêu cầu nghĩa là sao? Yêu cầu là cóp từ dòng A2, so với lúc chạy thử code cóp từ dòng nào? Đã thử thay tất cả những "dòng nào" kia thành "dòng yêu cầu" chưa?

Hai Lúa Miền Tây · 23/4/14

thanhduc_iit đã viết:

Em đã sử dụng code của bác Hai Lúa:

Mã:

Sub Gop()    
    Dim strFileName As Variant
    Dim myBook As Workbook
    Dim mySheet As Worksheet
    Dim i As Integer
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
                With ThisWorkbook.Sheets(1)
                    mySheet.Range("A1").CurrentRegion.Copy .Range("A65536").End(xlUp).Offset(1, 0)
                End With
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

Nhưng chưa theo đúng yêu cầu, bác có thể nào sửa đoạn code trên lại theo yêu cầu: Chỉ copy từ dòng A2 được k?

Bạn có thể điều chỉnh lại mà:

Mã:

Sub Gop()
    Dim strFileName As Variant, i As Integer
    Dim myBook As Workbook, mySheet As Worksheet, myRng As Range
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
               Set myRng = mySheet.[A1].CurrentRegion
               myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, myRng.Columns.Count).Copy _
                       ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

thanhduc_iit · 23/4/14

Hai Lúa Miền Tây đã viết:

Bạn có thể điều chỉnh lại mà:

Mã:

Sub Gop()
    Dim strFileName As Variant, i As Integer
    Dim myBook As Workbook, mySheet As Worksheet, myRng As Range
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
               Set myRng = mySheet.[A1].CurrentRegion
               myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, myRng.Columns.Count).Copy _
                       ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

Code của bác Hai Lúa Miền Tây là đúng với yêu cầu của em rồi đó ạ /-*+/

Cảm ơn bác rất nhiều.
Nhưng nếu file chỉ có tiêu đề dòng A1 thì sẽ bị dừng //////

Bác có thể viết code thêm nếu A2 rỗng thì bỏ qua không copy được k?
Thật sự thì VBA em không biết gì hết ạ.

Hai Lúa Miền Tây · 23/4/14

thanhduc_iit đã viết:
Code của bác Hai Lúa Miền Tây là đúng với yêu cầu của em rồi đó ạ Cảm ơn bác rất nhiều.
Nhưng nếu file chỉ có tiêu đề dòng A1 thì sẽ bị dừng Bác có thể viết code thêm nếu A2 rỗng thì bỏ qua không copy được k?
Thật sự thì VBA em không biết gì hết ạ.

Thêm dòng bỏ qua lỗi nhé.

Mã:

Sub Gop()
  [COLOR=#ff0000]  On Error Resume Next[/COLOR]
    Dim strFileName As Variant, i As Integer
    Dim myBook As Workbook, mySheet As Worksheet, myRng As Range
    strFileName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", _
                Title:="Select files", MultiSelect:=True)
    If IsArray(strFileName) Then
        Application.ScreenUpdating = False
        For i = LBound(strFileName) To UBound(strFileName)
            Set myBook = Workbooks.Open(strFileName(i))
            For Each mySheet In myBook.Worksheets
               Set myRng = mySheet.[A1].CurrentRegion
               myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, myRng.Columns.Count).Copy _
                       ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
            Next mySheet
            myBook.Close
        Next i
        Application.ScreenUpdating = True
    End If
End Sub

banvietdi · 17/9/14

Cảm ơn các bác quá cơ. Code của Bác Hai Lúa Miền Tây đúng cái em đang đau đầu, nhờ bác mà em như người mù thấy ánh sáng /-*+/

khoa186 · 20/12/15

xin lỗi em đào mộ tí ,các bác cho em hỏi bây giờ gần giống thế này,giả sử file con em có nhiều sheet 1, 2, 3 chẳng hạn , file tổng cũng có sheet 1,2,3 . Giờ em chỉ muốn sheet 1 tổng thì chỉ copy sheet 1 của file con , sheet 2 tổng thì copy sheet 2 của file con ......... File của bác @Hai Lúa Miền Tây thì copy tất cả các sheet của file con vào ,em thì chẳng biết sửa thế nào VBA của em thì chỉ copy paste thôi ah . - - - Cám ơn các bác nhé .
ps: mình có thể gán tên file hay tên sheet luôn được ko,tại vì mình chỉ có 20 flie , sheet con với sheet tổng mình đặt tên trùng nhau .

quần áo trẻ em | quan ao tre em | quần áo sơ sinh | quần áo bé trai | quần áo bé gái | bodysuit carter | quan ao so sinh | quan ao tre em nhap khau

Nhờ giúp code copy nhiều file excel trong thư mục thành 1 file (1 người xem)

Người dùng đang xem chủ đề này

thanhduc_iit

Thành viên chính thức

File đính kèm

Hau151978

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

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

VetMini

Ăn cùng góc phố

thanhduc_iit

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

thanhduc_iit

Thành viên chính thức

VetMini

Ăn cùng góc phố

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

thanhduc_iit

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

banvietdi

Thành viên mới

khoa186

Thành viên chính thức

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

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

Đếm ngược thời gian