Tổng hợp nhiều file Excel trong một thư mục (1 người xem)

[leonguyenz]

Xin lỗi BQT vì vấn đề này đã có trong forum nhưng em chưa biết về VBA nên không áp dụng được. Hiện tại ở công ty của em làm như vậy: mỗi quản lý có 1 file con, mỗi file 2 sheet, các sheet chỉ nhập liệu vùng A3:G152. Có rất nhiều file con như vậy, và có 1 file tổng (cũng có 2 sheet tương ứng) để tổng các file con (có thể tổng hợp trên 1 sheet nhưng phân loại dùm em). Em gửi file đính kèm xin các thầy và các anh chị giúp đỡ!

 

[ndu96081631]

Xin lỗi BQT vì vấn đề này đã có trong forum nhưng em chưa biết về VBA nên không áp dụng được. Hiện tại ở công ty của em làm như vậy: mỗi quản lý có 1 file con, mỗi file 2 sheet, các sheet chỉ nhập liệu vùng A3:G152. Có rất nhiều file con như vậy, và có 1 file tổng (cũng có 2 sheet tương ứng) để tổng các file con (có thể tổng hợp trên 1 sheet nhưng phân loại dùm em). Em gửi file đính kèm xin các thầy và các anh chị giúp đỡ!

Yêu cầu này rất dễ... Đầu tiên hãy Save file Tổng hợp.xlsx thành Tổng hợp.xlsm để có thể chạy được code, sau đó ta dùng ADO để tổng hợp
Code trong file Tổng hợp.xlsm

Sub GetData(SrcFile As Variant, SrcSheet As String, SrcRange As String, Target As Range, Header As Boolean, UseHeaderRow As Boolean)
  Dim rsCon As Object, rsData As Object
  Dim szConnect As String, szSQL As String
  Dim lCount As Long
  If Val(Application.Version) < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SrcFile & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(Header, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & SrcFile & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(Header, "Yes", "No") & """;"
  End If

  If SrcSheet = "" Then
    szSQL = "SELECT * FROM " & SrcRange$ & ";"
  Else
    szSQL = "SELECT * FROM [" & SrcSheet$ & "$" & SrcRange$ & "];"
  End If
  
  On Error GoTo ExitSub

  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")

  rsCon.Open szConnect
  rsData.Open szSQL, rsCon, 0, 1, 1
   
  If Not rsData.EOF Then
    If Header = False Then
      Target.Cells(1, 1).CopyFromRecordset rsData
    Else
      If UseHeaderRow Then
        For lCount = 0 To rsData.Fields.Count - 1
          Target.Cells(1, 1 + lCount).Value = rsData.Fields(lCount).Name
        Next
        Target.Cells(2, 1).CopyFromRecordset rsData
      Else
        Target.Cells(1, 1).CopyFromRecordset rsData
      End If
    End If
  End If
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  Exit Sub
ExitSub:
End Sub

Function FileNameList(ByVal FolderName As String)
  Dim Folder As String
  On Error Resume Next
  Folder = FolderName
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  ActiveWorkbook.Names.Add "Arr", "=""" & Folder & """&Files(""" & Folder & "*"")"
  FileNameList = Evaluate("Arr")
  ActiveWorkbook.Names("Arr").Delete
End Function

Và code chính để lấy dữ liệu:

  Dim Arr, Item, Sh As Worksheet
  Arr = FileNameList(ThisWorkbook.Path)
  Set Sh = ActiveSheet
  Sh.Range("A3:G1000").ClearContents
  On Error Resume Next
  For Each Item In Arr
    If CStr(Item) <> ThisWorkbook.FullName Then
      GetData CStr(Item), Sh.Name, "A3:G152", Sh.Range("A100000").End(xlUp).Offset(1), False, False
    End If
  Next
End Sub

Đứng tại sheet nào, chạy code sẽ tổng hợp cho sheet đó
Test thử xem có trục trặc gì không nha!

 

[leonguyenz]

Rất đúng với mong muốn của em. Cảm ơn thầy rất nhiều, chúc thầy và gia đình nhiều niềm vui và nhiều sức khỏe !

 

[nhunghap]

chào các a chị trong diễn đàn em có một mong muốn cần anh chị giúp đỡ ạ,
em cân tổng hợp lương và thu nhập của toàn bộ công nhân viên trong nhà máy trong một năm vào một sheet, mah mỗi tháng lương e lại làm tại một bảng riêng rất mong anh chị hướng dẫn e tạo được một bảng tổng hợp thu nhập như vậy và một tháng lương của e sẽ có cấu trúc như bảng đính kèm, mong các a chị giúp e làm dược một bẳng cuối năm có cấu trúc như vậy, tuy nhiên do là công ty may nên lao động thường biến động có cách nào đó mà loại bỏ được nhưng người nghỉ việc rồi thì càng tốt e chân thành cám ơn.