Nhờ sửa dùm code Import dữ liệu từ 1 file khác có nhiều hơn 3 sheet

[LuuGiaPhúc]

Chào các anh chị,
Nhờ các anh chị xem giúp em đoạn code để import dữ liệu từ file khác
Code này sai chỗ nào mà tại sao khi chỉ đường dẫn đến 1 file khác có nhiều sheet (từ 3 sheet trở lên) thì nó luôn luôn chỉ import 2 sheet đầu thôi.
Em cảm ơn ạ

Sub Import()
Dim LastRow As Long
Dim chonfile As Variant
Dim i As LongPtr, j As LongPtr, a As Long, lrn As Long, lr As Long
Dim openfile
Dim sh As Worksheet, sn As Worksheet
Dim mn(), md
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:CF" & LastRow).Clear

Set sh = ThisWorkbook.Sheets("Sheet1")
On Error Resume Next
chonfile = Application.GetOpenFilename(Title:="Chon file...", filefilter:="exel file(*.xls*),*.xls*", MultiSelect:=True)
For i = 1 To UBound(chonfile)
Set openfile = Workbooks.Open(chonfile(i))
For j = 1 To Sheets.Count
Set sn = openfile.Sheets(j)
sn.Activate
a = 6 ' noi bat dau copy
lrn = sn.Cells(a, 1).End(xlDown).Row
sn.Range(Cells(a, 1), Cells(lrn, 32)).Copy 'Cells(a, 1): so 1 là cot A , Cells(lrn, 32) : So 32 là cot cuôi cùng can copy
sh.Range("A" & lr + 2).PasteSpecial xlPasteValues 'Cot A la cot bat dau paste vao
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
Next j
openfile.Close
Next
On Error GoTo 0
sh.Select
sh.Range("A6").Select
MsgBox "Da import tong cong : " & i - 1 & " file " & j - 1 & " Sheet vào sheet1"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Nó chỉ import được 2 sheet đầu tiên, đến hàng thứ 130 002 thì nghỉ, không chịu paste tiếp sheet 3

 

[ptm0412]

Tôi vừa thử 2 file, file 1 có 4 sheets, file 2 có 5 sheets, và copy đủ.

 

[LuuGiaPhúc]

Tôi vừa thử 2 file, file 1 có 4 sheets, file 2 có 5 sheets, và copy đủ.

Dạ, vậy em gởi file anh xem giúp, chứ em import nhiều file khác nhau trên máy em rồi ạ, đều dừng ở hàng thứ 130 002.
Hay có khi nào máy em lỗi ? em dùng office 365 64bit. Em gởi file report mà máy em lấy không được nè anh. Do file quá lớn , mỗi sheet có 65005 hàng , cột thì tới DM không up lên dc, em xóa hết, giữ lại 2 cột đầu thôi cho nhỏ file lại (nhưng cũng không import vào dc đủ 3 sheet,) nhờ anh xem giúp nhé. Em cảm ơn

Em có thử : import 3 file , mỗi file 2 sheet thì nó cũng vẫn dừng ở hàng thứ 130004.
Vậy tạm hiểu vấn đề không nằm ở các file data kia, mà nằm ở chính file tổng này .

 

[ptm0412]

Bạn sửa như sau:

    For i = 1 To UBound(chonfile)
        Set openfile = Workbooks.Open(chonfile(i))
        For j = 1 To openfile.Sheets.Count
            Set sn = openfile.Sheets(j)
            openfile.Activate
            sn.Activate
            a = 6  '' noi bat dau copy
            lrn = sn.Cells(a, 1).End(xlDown).Row
            sn.Range(sn.Cells(a, 1), sn.Cells(lrn, 2)).Copy    ''Cells(a, 1): so 1 là cot A , Cells(lrn, 24) : So 24 là cot cuôi cùng can copy
            ThisWorkbook.Activate
            sh.Activate
            sh.Range("A" & lr + 2).PasteSpecial xlPasteValues   ''Cot A la cot bat dau paste vao
            lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
        Next j
        openfile.Close
    Next

- Trước khi copy phải activate workbook nguồn và sheet nguồn
- Trước khi paste phải activate workbook đích và sheet đích
Trừ khi không copy mà gán giá trị
- sn.Range thì bên trong phải là sn.Cells 2 chỗ

Mặc dù tôi chạy 2 file 9 sheets không lỗi, nhưng với file của bạn phải sửa như trên.

 

[LuuGiaPhúc]

Bạn sửa như sau:

    For i = 1 To UBound(chonfile)
        Set openfile = Workbooks.Open(chonfile(i))
        For j = 1 To openfile.Sheets.Count
            Set sn = openfile.Sheets(j)
            openfile.Activate
            sn.Activate
            a = 6  '' noi bat dau copy
            lrn = sn.Cells(a, 1).End(xlDown).Row
            sn.Range(sn.Cells(a, 1), sn.Cells(lrn, 2)).Copy    ''Cells(a, 1): so 1 là cot A , Cells(lrn, 24) : So 24 là cot cuôi cùng can copy
            ThisWorkbook.Activate
            sh.Activate
            sh.Range("A" & lr + 2).PasteSpecial xlPasteValues   ''Cot A la cot bat dau paste vao
            lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
        Next j
        openfile.Close
    Next

- Trước khi copy phải activate workbook nguồn và sheet nguồn
- Trước khi paste phải activate workbook đích và sheet đích
Trừ khi không copy mà gán giá trị
- sn.Range thì bên trong phải là sn.Cells 2 chỗ

Mặc dù tôi chạy 2 file 9 sheets không lỗi, nhưng với file của bạn phải sửa như trên.

Em cảm ơn anh rất nhiều, đã lấy đủ hết các dòng rồi anh ơi.
Cho em hỏi thêm, nếu em muốn lấy các cột không liên tục, ví dụ : lấy cột A:C , F:K thôi, chứ không lấy toàn bộ các cột, thì có thể sửa code này lại như thế nào ạ. Hiện giờ em đang dùng code này và sau đó thêm cái macro xóa các cột dư thừa kia, nhưng như vậy có vẻ không hay lắm (tuy vẫn đáp ứng đúng nhu cầu).
Em cảm ơn anh .

 

[ptm0412]

Cách 1: Copy 2 lần
Cách 2: copy hết các sheet xong xóa các cột giữa 1 lần.

Do bạn hỏi code nên tôi trả lời đúng trên code của bạn, thực ra:
- Nếu là VBA: không copy paste mà gán giá trị, mỗi sheet 2 lần
- Có thể dùng ADO và chỉ Select cột cần lấy
- Nên dùng power query, combine sheet và xóa cột thừa ngay trong query.
Hai cách sau hay ở chỗ khi thay đổi dữ liệu hoặc thêm sheet, chỉ cần refresh.