Nối 4 file excel thành 1 file excel tổng

[VUDER]

chào các anh chị
em có 4 file excel co cùng 1 tiêu đề (sheet 1 , sheet 2 , sheet 3, sheet 4), bay giờ em muốn nối 4 file này vào file tổng nhưng em không biet làm bang cách nào, mong anh chị giúp em với

 

[ndu96081631]

chào các anh chị
em có 4 file excel co cùng 1 tiêu đề (sheet 1 , sheet 2 , sheet 3, sheet 4), bay giờ em muốn nối 4 file này vào file tổng nhưng em không biet làm bang cách nào, mong anh chị giúp em với

Bài này phải lập trình VBA bạn à. Code trong file tong nhu sau

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 Arr, vFile, FileName
  Dim n As Long
  vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    For Each FileName In vFile
      n = n + 1
      Arr = GetData(CStr(FileName), "", "", True, (n = 1))
      Range("A60000").End(xlUp).Offset(1).Resize(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1).Value = Arr
    Next
  End If
End Sub

Cách dùng:
- Chạy Sub Main
- Cửa sổ Open File hiện ra. Dùng chuột chọn file đầu tiên (sheet1.xlsx), bấm giữ phím Shift và chọn chuột vào file cuối cùng (sheet4.xlsx)
- Bấm Open
Xong!
Lưu ý: File tong phải được lưu theo định dạng xlsm (mới dùng được code VBA)