Xin giúp đỡ code tổng hợp dữ liệu từ nhiều file excel vào 1 file

[LYSM]

Em chào các anh chị!
Em đã đọc nhiều về chủ đề này rồi nhưng tìm mãi mà không được code đúng yêu cầu nên mạo muội nhờ các anh chị giúp đỡ. Em có 1 file excel cần tổng hợp dữ liệu từ nhiều file nguồn khác nhau, các file cần lấy dữ liệu có chung 1 form và cùng 1 kiểu thông tin, file nguồn có nhiều vùng dữ liệu cần lấy, cụ thể các anh chị xem trong file tổng hợp giúp em. Em cám ơn các anh chị nhiều!

 

[snow25]

Em chào các anh chị!
Em đã đọc nhiều về chủ đề này rồi nhưng tìm mãi mà không được code đúng yêu cầu nên mạo muội nhờ các anh chị giúp đỡ. Em có 1 file excel cần tổng hợp dữ liệu từ nhiều file nguồn khác nhau, các file cần lấy dữ liệu có chung 1 form và cùng 1 kiểu thông tin, file nguồn có nhiều vùng dữ liệu cần lấy, cụ thể các anh chị xem trong file tổng hợp giúp em. Em cám ơn các anh chị nhiều!

Bạn thử xem đúng không nhé.

Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 1000, 1 To 14), a As Long
     Dim sarr
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For Each k In .SelectedItems
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select * From [sheet1$a1:e30]"
       sarr = cn.Execute(sqlStr).GetRows
       a = a + 1
       arr(a, 1) = a
       arr(a, 2) = sarr(1, 3)
       arr(a, 3) = sarr(1, 0)
       arr(a, 4) = sarr(1, 2)
       arr(a, 5) = sarr(1, 1)
       arr(a, 9) = sarr(4, 7)
       arr(a, 10) = sarr(4, 8)
       arr(a, 11) = sarr(4, 9)
       arr(a, 12) = sarr(4, 10)
       arr(a, 13) = sarr(4, 11)
       arr(a, 14) = sarr(1, 24) & Chr(10) & sarr(1, 25) & Chr(10) & sarr(1, 26) & Chr(10) & sarr(1, 27) & Chr(10) & sarr(1, 28)
       cn.Close
    Next
    End With
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 12 Then .Range("A13:N" & lr).ClearContents
         If a Then .Range("A13:N13").Resize(a).Value = arr
     End With
End Sub

 

[LYSM]

Bạn thử xem đúng không nhé.

Dạ đúng rồi ạ, em cám ơn nhiều ạ, phần ghi chú có cách nào bỏ qua những dòng dữ lieu trống không ạ? em thấy nó vẫn ghép cả các ô trống vào.

 

[snow25]

Dạ đúng rồi ạ, em cám ơn nhiều ạ, phần ghi chú có cách nào bỏ qua những dòng dữ lieu trống không ạ? em thấy nó vẫn ghép cả các ô trống vào.

Bạn xem lại nhé.

Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 1000, 1 To 14), a As Long
     Dim sarr, j As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For Each k In .SelectedItems
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select * From [sheet1$a1:e30]"
       sarr = cn.Execute(sqlStr).GetRows
       a = a + 1
       arr(a, 1) = a
       arr(a, 2) = sarr(1, 3)
       arr(a, 3) = sarr(1, 0)
       arr(a, 4) = sarr(1, 2)
       arr(a, 5) = sarr(1, 1)
       arr(a, 9) = sarr(4, 7)
       arr(a, 10) = sarr(4, 8)
       arr(a, 11) = sarr(4, 9)
       arr(a, 12) = sarr(4, 10)
       arr(a, 13) = sarr(4, 11)
       arr(a, 14) = sarr(1, 24)
       For j = 25 To 28
          If sarr(1, j) <> Empty Then arr(a, 14) = arr(a, 14) & Chr(10) & sarr(1, j)
       Next j
       cn.Close
    Next
    End With
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 12 Then .Range("A13:N" & lr).ClearContents
         If a Then .Range("A13:N13").Resize(a).Value = arr
     End With
End Sub

 

[LYSM]

Bạn xem lại nhé.

Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 1000, 1 To 14), a As Long
     Dim sarr, j As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For Each k In .SelectedItems
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select * From [sheet1$a1:e30]"
       sarr = cn.Execute(sqlStr).GetRows
       a = a + 1
       arr(a, 1) = a
       arr(a, 2) = sarr(1, 3)
       arr(a, 3) = sarr(1, 0)
       arr(a, 4) = sarr(1, 2)
       arr(a, 5) = sarr(1, 1)
       arr(a, 9) = sarr(4, 7)
       arr(a, 10) = sarr(4, 8)
       arr(a, 11) = sarr(4, 9)
       arr(a, 12) = sarr(4, 10)
       arr(a, 13) = sarr(4, 11)
       arr(a, 14) = sarr(1, 24)
       For j = 25 To 28
          If sarr(1, j) <> Empty Then arr(a, 14) = arr(a, 14) & Chr(10) & sarr(1, j)
       Next j
       cn.Close
    Next
    End With
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 12 Then .Range("A13:N" & lr).ClearContents
         If a Then .Range("A13:N13").Resize(a).Value = arr
     End With
End Sub

Vâng, chuẩn rồi ạ, em cám ơn nhiều!

 

[LYSM]

Bạn xem lại nhé.

Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(1 To 1000, 1 To 14), a As Long
     Dim sarr, j As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For Each k In .SelectedItems
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=yes;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select * From [sheet1$a1:e30]"
       sarr = cn.Execute(sqlStr).GetRows
       a = a + 1
       arr(a, 1) = a
       arr(a, 2) = sarr(1, 3)
       arr(a, 3) = sarr(1, 0)
       arr(a, 4) = sarr(1, 2)
       arr(a, 5) = sarr(1, 1)
       arr(a, 9) = sarr(4, 7)
       arr(a, 10) = sarr(4, 8)
       arr(a, 11) = sarr(4, 9)
       arr(a, 12) = sarr(4, 10)
       arr(a, 13) = sarr(4, 11)
       arr(a, 14) = sarr(1, 24)
       For j = 25 To 28
          If sarr(1, j) <> Empty Then arr(a, 14) = arr(a, 14) & Chr(10) & sarr(1, j)
       Next j
       cn.Close
    Next
    End With
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 12 Then .Range("A13:N" & lr).ClearContents
         If a Then .Range("A13:N13").Resize(a).Value = arr
     End With
End Sub

Bác Snow25 cho em hỏi ạ, sau một thời gian vận hành em thấy có một vấn đề là khi cell B26-B30 quá nhiều ký tự thì vào file tổng hợp nó sẽ bị thiếu nội dung (chỉ được mỗi cell là 255 ký tự) bác có cách nào mở rộng số ký tự này không ạ(Cụ thể là file của An ạ)? Em cám ơn!

 

[LYSM]

Hic, ai giúp em với ạ, em đang bế tắc quá