Tổng hợp dữ liệu từ nhiều file excel vào 1 file không cần mở file

Quảng cáo

Tổng hợp dữ liệu từ nhiều file excel vào 1 file không cần mở file​


Bài toán đặt ra như sau:

Mình lúc nào cũng sẽ có 5 file dữ liệu (mỗi file khoảng 2000-5000 dòng dữ liệu), download trực tiếp hàng ngày từ server với định dạng định sẵn dưới định dạng .xls (số cột và vị trí cột định sẵn theo mẫu đính kèm là các file CA1, CA2, CA3, CA4, CA5). Mình cần tổng hợp lại 5 file vào 1 file duy nhất (như mẫu đính kèm) trong đó du liệu của các file CA1, CA2, CA3, CA4, CA5 sẽ nối tiếp nhau ghep vào 1 sheet theo đúng cột tương ứng. Để tổng hợp đc mà k cần mở cả 5 file lên là tốt nhất (như kiểu paste link và có linh external data vậy).

Bài toán trên chỉ là một trong những nhu cầu của rất nhiều người về việc làm thế nào để tổng hợp dữ liệu từ nhiều file Excel khác nhau vào chung một file.

32387587165_4ffaa22514_o.png[SIZE=3][SIZE=2]


Để làm được điều này, bạn hãy sử dụng đoạn code sau.

Mã:
Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)
          
  Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")

  If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon

  szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function

Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "[B]A8:V10000[/B]"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub

Cách dùng:
- Cho code trên vào Module
- Chạy sub Main
- Cửa sổ Open File hiện ra, dùng chuột chọn file đầu, bấm giữ phím Shift rồi còn file cuối ---> Bấm nút Open
- Chờ trong giây lát, khi MsgBox hiện ra báo hiệu hoàn tất, kiểm tra lại dữ liệu trong file hiện hành xem đã cập nhật chưa
-------------
Lưu ý: File TongHop phải được lưu theo định dạng XLSM (nếu lưu bằng XLSX sẽ mất sạch code). Ngoài ra, bạn cũng lưu ý đoạn tô đậm A8:V10000 tô đậm trên chính là địa chỉ lấy dữ liệu. Nếu dữ liệu của bạn bắt đầu từ A2 đến F100 chẳng hạn, bạn có thể sửa thành A2:F100 để bảo đảm sự chính xác.

Chúc bạn thành công!

Một số bài viết có liên quan:
1/ Làm cách nào để ghi chú hiệu quả trong VBA?
2/ Conditional Formatting cho biểu đồ bằng VBA
3/ Khi nào nên sử dụng Msgbox, Inputbox và Userform?
4/ 8 thủ thuật trong VBE bạn nên biết
5/ Kích hoạt macro từ nút bấm ngoài bảng tính
6/ Làm thế nào để thay thế các chữ OK, CANCEL,... nhàm chán của Msgbox
7/ Giới thiệu VBA trong Excel
8/ Viết code để nhìn thấy ai là người cập nhật bảng tính của bạn lần gần đây nhất
9/ 4 cách sử dụng Immediate Window trong VBA hiệu quả hơn
10/ 3 gợi ý nhỏ mang lại thành công trong khai báo biến trong VBA
 

File đính kèm

  • tong hop du lieu vao 1 file.rar
    51.2 KB · Đọc: 133
Chỉnh sửa lần cuối bởi điều hành viên:
Chào Anh(Chị) Và Các Bạn GPE,
File TONG HOP không lấy dữ liệu đầy đủ của file CA 1 cột F(data6). Anh chị và các bạn kiểm tra và chỉ mình cách chỉnh sửa dùm.
Chân thành cảm ơn.
 

File đính kèm

  • TH.rar
    71 KB · Đọc: 7
Chào các anh chị
Mình phải tổng hợp từ nguồn rất nhiều file.
Vậy Mình muốn đếm số file mà mình tổng hợp ( khi bấm Get data và lựa chọn số file tổng hợp) và đưa ra thông báo màn hình hoặc đưa ra tới một ô cell thì làm thế nào. Không lẽ đếm bằng tay trước.
rất mong được anh chị giúp đỡ.
 
Lần chỉnh sửa cuối:
bác có thể giúp e cái này với được không ạ. file ví dụ đây ạ https://goo.gl/quE1HZ .Emuốn khi nhập thông tin bất kỳ vào 1 ô ở sheet 1 thì sẽ tự động dò tìm ra thông tin từ những sheet còn lại. ví dụ khi nhập vào ô stt là 1 thì sẽ tự động hiển thị ra thông tin của những người có stt là 1 ý ạ. Tìm kiếm trên 1 sheet thì e có thể dùng hàm Vlookup nhưng trên nhiều sheet thì e chưa biết xử lý sao, mong các bác giúp e với ạ
 
Anh ơi, em thử code như anh mà ko chạy được. Anh có thể giúp em xem code này bị lỗi gì mà cứ báo Subcript out of range ạ?

Sub GopFileExcel()
Dim FilesToOpen
Dim x As Integer

On Error GoTo ErrHandler
Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files ((*.), *.", MultiSelect:=True, Title:="Files to Merge")

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))
Col = wb.Sheets(1).UsedRange.Columns.Count + 1
wb.Sheets(1).Cells(1, Col) = "File name"
wb.Sheets(1).Range(Cells(2, Col), Cells(wb.Sheets(1).UsedRange.Rows.Count, Col)).Value = wb.Name
wb.Sheets(1).Range("$A$1:$AE$65000").AutoFilter Field:=11, Criteria1:="42???"
If x = 1 Then
wb.Sheets(1).UsedRange.Copy Workbooks("Join").Sheets(1).Range("A1")
Else
lr = Workbooks("Join").Sheets(1).UsedRange.Rows.Count
wb.Sheets(1).UsedRange.Offset(1).Copy Workbooks("Join").Sheets(1).Range("A" & lr + 1)
End If
wb.Close False
x = x + 1
Wend
Workbooks("Join").Save

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

Cám ơn anh!
 
Giúp e với ạ, e cần tổng hợp nhiều file các tháng vào 1file và số lượng được chạy lũy kế với tỉ lệ % cũng phải chạy ạ, e cũng đã chạy thử theo thủ công nhưng file quá nặng ạ, anh chị giúp e với ạ
Xin cảm ơn ạ
 

File đính kèm

  • A.xlsx
    32 KB · Đọc: 4
Giúp e với ạ, e cần tổng hợp nhiều file các tháng vào 1file và số lượng được chạy lũy kế với tỉ lệ % cũng phải chạy ạ, e cũng đã chạy thử theo thủ công nhưng file quá nặng ạ, anh chị giúp e với ạ
Xin cảm ơn ạ
Bài này nên dùng Power query (nói chung là cả chủ đề này)
 
Quảng cáo
Top Bottom