ạDạ, là trường hợp 2 anh ạ "2/hay là copy và dán liên tiếp xuống dưới, hết sh này tiếp đến sh khác."
Bạn tham khảo file đính kèm và code bên dưới.
Sub CombineData()
Dim FSo As Object, oFolder As Object, oFile As Object
Dim Wb As Workbook, Master As Worksheet, Data()
Dim FolderPath As String, fName As String
Dim fR As Integer, lR As Integer
Application.ScreenUpdating = False
Set Master = ThisWorkbook.Sheets("Sheet1")
'Xoa du lieu cu
Master.Range("A1").CurrentRegion.Offset(1).ClearContents
'Duong dan Folder can tong hop thong tin
FolderPath = "C:\Users\Thinh Nguyen\OneDrive\Desktop\Tien ve GHTK" 'Thay doi ten Folder can tong hop tren may cua ban
'Khai bao FSo
Set FSo = CreateObject("Scripting.FileSystemObject")
'Chon Folder
Set oFolder = FSo.getfolder(FolderPath)
'Chay vong lap qua tung file trong Folder duoc chon
For Each oFile In oFolder.Files
'Kiem tra de lay file Excel bang ten duoi
If FSo.getextensionname(oFile) Like "xls*" Then
'Ten file
fName = oFile.Name
'Mo file
Set Wb = Workbooks.Open(oFile)
'Sheet dau tien cua file duoc mo
With Wb.Worksheets(1)
'Tim vi tri dong dau tien co du lieu can lay
fR = .Columns("A:A").Find("STT").Row + 1
'Tim vi tri dong cuoi cung co du lieu can lay
lR = .Range("H" & Rows.Count).End(xlUp).Row - 1
'Gan du lieu can lay vao mang 2 chieu
Data() = .Range("A" & fR).Resize(lR - fR + 1, 27).Value
End With
'Dong file
Wb.Close
'Dien du lieu vao Master
fR = Master.Range("A" & Rows.Count).End(xlUp).Row + 1
Master.Range("A" & fR).Resize(UBound(Data, 1), 27) = Data
'Dien cot ten file
Master.Range("AB" & fR).Resize(UBound(Data, 1)) = fName
End If
Next oFile
Set Master = Nothing: Set Wb = Nothing
Set FSo = Nothing: Set oFolder = Nothing: Set oFile = Nothing
Application.ScreenUpdating = False
MsgBox "Done", vbInformation, "GPE"
End Sub
Trong khi chờ các giải pháp khác, hãy thử thêm 1 đoạn code sau:
Option Explicit
Sub TongHop()
Dim i&, j&, Lr&, R&, C&, t&, k&
Dim Arr(), Res()
Dim Dic As Object, Key
Dim Ws As Worksheet, Sh As Worksheet
Dim WbMoi As Workbook, WbD As Workbook
Dim file As Variant, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Sh = Sheets("Tong Hop")
Lr = Sh.Cells(Rows.Count, 26).End(xlUp).Row
ReDim Res(1 To 10000, 1 To 28)
For Each file In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Admin\Downloads\Tien ve GHTK\").Files
If file.Name Like "*.xls" Then
If Lr > 28 Then
Set Rng = Sh.Range("AB28:AB" & Lr)
If Rng.Find(file.Name) Is Nothing Then
Set WbMoi = Workbooks.Open(file)
For Each Ws In WbMoi.Sheets
Lr = Ws.Cells(Rows.Count, 26).End(xlUp).Row - 1
If Lr < 30 Then Exit For
Arr = Ws.Range("A29:AA" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
For i = 1 To R
t = t + 1
Res(t, 28) = file.Name
For j = 1 To C
Res(t, j) = Arr(i, j)
Next j
Next i
Next Ws
WbMoi.Close
End If
Else
Set WbMoi = Workbooks.Open(file)
For Each Ws In WbMoi.Sheets
Lr = Ws.Cells(Rows.Count, 26).End(xlUp).Row - 1
If Lr < 30 Then Exit For
Arr = Ws.Range("A29:AA" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
For i = 1 To R
t = t + 1
Res(t, 28) = file.Name
For j = 1 To C
Res(t, j) = Arr(i, j)
Next j
Next i
Next Ws
WbMoi.Close
End If
End If
Next file
Lr = Sh.Cells(Rows.Count, 26).End(xlUp).Row
Sh.Rows(Lr + 1 & ":" & Lr + t).Insert Shift:=xlDown
Sh.Range("A" & Lr + 1).Resize(t, 28) = Res
Sh.Range("A29").Resize(t, 28).Select
With Selection
.Interior.Color = xlNone
.Borders.LineStyle = 1
.Font.Bold = False
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End SubDạ vâng anh ạ. Em là người tổng hợp lại ạ
Dạ, e cảm ơn ạ
Dạ, Vâng ạ. E cảm ơn ạ
Sao hay vậy Bạn
)
