Option Explicit
Sub ThopDT()
Dim FSO, SourceFolder, SubFolder, Tb As String
Dim FileItem, r As Long, Cl1 As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(ThisWorkbook.Path & "\")
Sheet6.[A4:I65536].ClearContents
Set Cl1 = Sheet6.[A4]
For Each FileItem In SourceFolder.Files
If FileItem.Type = "Microsoft Excel Worksheet" Then
If FileItem.Name <> ThisWorkbook.Name Then
Copydata FileItem.Path, Cl1, Tb
End If
End If
Next
MsgBox Tb, , "GPE"
Thoat:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub Copydata(ByVal Ten As String, ByRef Vt As Range, ByRef Tb As String)
Dim Wb As Workbook, Sh As Worksheet, Sh1 As Worksheet
Dim Cl As Range, Tm, j, Tm1()
Set Wb = Workbooks.Open(Ten)
Set Sh = Wb.Sheets(1)
Set Cl = Sh.[B65536].End(3).Offset(-1)
If Cl.Row < 4 Then Exit Sub
Tm = Sh.Range(Sh.[B4], Cl).Resize(, 14)
ReDim Tm1(1 To UBound(Tm, 1), 1 To 5)
For j = 1 To UBound(Tm, 1)
Tm1(j, 1) = Sh.Name
Tm1(j, 2) = Tm(j, 1)
Tm1(j, 3) = Tm(j, 7)
Tm1(j, 4) = Tm(j, 13)
Tm1(j, 5) = Tm(j, 14)
Next
Vt.Resize(UBound(Tm, 1), 5) = Tm1
Set Vt = Vt.Offset(UBound(Tm, 1))
'Tao Sheet rieng
On Error Resume Next
ThisWorkbook.Sheets(Sh.Name).Delete
On Error GoTo Thoat
Set Sh1 = ThisWorkbook.Sheets.Add
Sh1.Name = Sh.Name
Sh1.[A9].Resize(UBound(Tm, 1), 5) = Tm1
Sh1.[A9].Resize(UBound(Tm, 1)).ClearContents
Sheet1.[A1:G8].Copy Sh1.[A1]
For j = 1 To 7
Sh1.Columns(j).ColumnWidth = Sheet1.Columns(j).ColumnWidth
Next
Sh1.[A5] = Sh1.[A5] & " " & Sh.Name
Sheet1.[A11:G11].Copy
Sh1.[A9].Resize(UBound(Tm, 1), 7).PasteSpecial Paste:=xlPasteFormats
Sheet1.[A15:G37].Copy Sh1.[A9].Offset(UBound(Tm, 1))
If Len(Tb) = 0 Then Tb = "KET QUA TONG HOP DU LIEU"
Tb = Tb & Chr(10) & Ten & " << So dong: " & UBound(Tm, 1) & ">>"
Wb.Close
Thoat:
Set Wb = Nothing
Set Sh = Nothing
End Sub
