Tổng hợp dữ liệu từ nhiều file excel vào 1 file

[huynhphuong thcspt]

Nhờ các bạn trên diễn đàn chỉnh lại (xem) dùm code sau. Mình không biết lỗi ở đâu mà cứ mỗi lần copy (dữ liệu) nhiều file vào 1 file thì 2 file đầu dữ liệu copy đúng, bất đầu từ file thứ 3 trở đi thì bị bỏ trống khoảng 4 dòng trở lên rồi mới copy dữ liệu vào. Chân thành cảm ơn.
CODE NHƯ SAU (sưu tầm trên điễn đàn):
Sub GopFileExcel()
'XOA DU LIEU TRUOC KHI TH

Sheets("DATA").Select
Range("A1:AZ1").EntireColumn.Delete
'KHAI BAO TH
Dim FilesToOpen
Dim x As Integer
Dim wb As Workbook
'LENH TH
On Error GoTo ErrHandler
Application.DisplayAlerts = False 'tat canh bao
Application.ScreenUpdating = False 'tat nhay man hinh
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", MultiSelect:=True, Title:="Files to Merge")

If MsgBox("Ban co muon chac tong hop du lieu dia ban khong?", vbYesNo) = vbYes Then 'canh bao tong hop dia ban

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1
While x <= UBound(FilesToOpen)
Set wb = Workbooks.Open(Filename:=FilesToOpen(x))

If x = 1 Then
wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(1).Range("A1")
Else
lr = ThisWorkbook.Sheets(1).UsedRange.Rows.Count
wb.Sheets(1).UsedRange.Offset(4).Copy ThisWorkbook.Sheets(1).Range("A" & lr + 1)
End If

wb.Close False
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True 'tat nhay man hinh
Application.DisplayAlerts = True 'tat canh bao
Set wb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler

End If 'ket thuc canh bao tong hop dia ban
End Sub

 

[huynhphuong thcspt]

Có 2 vấn đề ở b.2/:
1/ Việc đưa Z3, AA2, AC2 xuống Range("AN" & dCH) hoặc Range("AO" & dCH) chỉ cần 1 lần thì bạn lại cho luôn vào vòng lặp => Chậm thực thi công việc và còn sinh ra vấn đề 2/
2/ Việc phải bấm 2 lần là do: mảng arr đã được lấy trước khi thực hiện vòng lặp, trong khi bạn làm những việc đã nói ở 1/ trong vòng lặp thì làm sao có dữ liệu mới trong arr được. VD 2 câu sau đây:
Sheet4.Range("AO" & dCH) = Sheet4.Range("Z3") 'chừ mới lấy từ Z3 xuống AO13
Sheet1.Cells(i, 50) = arr(k, 40) 'Nhưng arr(k, 40) là số cũ đã lấy từ đầu code rồi
=> Do đó phải làm các việc ở 1/ trước dòng arr = Sheet4.Range("B9:AO" & endR). Tuy nhiên cách giải quyết hay nhất là sửa ngay trên dòng của chủ hộ tại bảng tạm (dòng 13). Các loại khuyết tật mà tôi code cũng phải sửa tại đây và lấy tại đây cấp nhật vào Data chứ tại đâu nữa.

Vấn đề nhỏ là trong code thừa 2 dòng lấy sCH và dCH
' sCH = Mid(Sheet4.Range("J2"), InStr(1, Sheet4.Range("J2"), "ch"), 6) 'THUA DONG
' dCH = Sheet4.Range("D9" & UBound(arr, 1) + 8).Find(What:=sCH, LookIn:=xlFormulas, LookAt:=xlWhole).Row 'THUA CODE

Chào bạn Maika8008, Chân thành cảm ơn bạn hướng dẫn cách khắc phụ sự cố.
Báo cáo bạn: Theo sự hướng dẫn của bạn mình đã khắc phục xong. Chương trình chạy nhanh, gọn khớp dữ liệu.

Sub SaveInfoToData()
Dim arr, arrCol, arrCol2, arrCol3
Dim i&, j&, k&, endR&, endR1&, rw&
Dim dCH As Long
Dim sCH As String
endR1 = Sheet4.Range("D9").End(xlDown).Row
endR = Sheet4.Range("B7").End(xlDown).Row
If endR < 9 Then Exit Sub
sCH = Mid(Sheet4.Range("J2"), InStr(1, Sheet4.Range("J2"), "ch"), 6)
dCH = Sheet4.Range("D9:D" & endR1).Find(What:=sCH, LookIn:=xlFormulas, LookAt:=xlWhole).Row
Sheet4.Range("AO" & dCH) = Sheet4.Range("Z3")
If Sheet4.Range("AA2") = "" And Sheet4.Range("AC2") = "" Then
Sheet4.Range("AN" & dCH) = Sheet4.Range("AA2")
     ElseIf Sheet4.Range("AA2") <> "" And Sheet4.Range("AC2") = "" Then
     Sheet4.Range("AN" & dCH) = Sheet4.Range("AA2")
     ElseIf Sheet4.Range("AA2") = "" And Sheet4.Range("AC2") <> "" Then
     Sheet4.Range("AN" & dCH) = Sheet4.Range("AC2")
End If
arr = Sheet4.Range("B9:AO" & endR)
rw = Sheet1.Range("O4:O" & Sheet1.Range("O" & Rows.Count).End(xlUp).Row).Find(What:=Sheet4.Range("C1"), LookIn:=xlFormulas, LookAt:=xlWhole).Row
arrCol = Array(3, 4, 48, 5, 6, 7, 8, 9, 10, 49, 19, 21, 23, 24, 25, 26, 28, 29, 30, 31, 32, 33, 34, 35)
arrCol2 = Array(44, 45, 46)
arrCol3 = Array(36, 37, 38, 39, 40, 41, 42, 43)
Application.ScreenUpdating = False
For i = rw To rw + endR - 9
    k = k + 1
    Sheet1.Cells(i, 51) = arr(k, 29)
    Sheet1.Cells(i, 12) = Sheet4.Range("L2")
    Sheet1.Cells(i, 13) = Sheet4.Range("M2")
    Sheet1.Cells(i, 50) = arr(k, 40)
    Sheet1.Cells(i, 17) = arr(k, 39)
    For j = 1 To 24
        Sheet1.Cells(i, arrCol(j)) = arr(k, j)
    Next
    For j = 26 To 28
        Sheet1.Cells(i, arrCol2(j - 25)) = arr(k, j)
    Next
    For j = 31 To 38
        Sheet1.Cells(i, arrCol3(j - 30)) = arr(k, j)
    Next
Next
Application.ScreenUpdating = True
End Sub

Chúc bạn An lành và Hạnh phúc. Chào bạn!