Const wsName As String = "$Name#Temp$"
Const sName As String = "Sheet1"
Const maxR As Long = 10000
Dim arPath()
Dim arPath2()
Dim ArrType As Variant
Dim member_Book As Workbook
Sub Main()
SpeedOn True
Const extFile As String = "tsv,xlsx,xls,xlsm"
Dim pthFolder As String, Rng As Range, ws As Worksheet, i As Long, maxC As Long, arr
''Xoa du lieu o sheet tong hop:
Sheet1.UsedRange.ClearContents
ArrType = Split(extFile, ",")
''Them sheet tam:
AddTempSheet
Set ws = Sheets(wsName)
''Lay duong dan thu muc nguon:
pthFolder = GetPathFolder("")
If Len(pthFolder) = 0 Then GoTo EXIT_MAIN
''Tao dan cong thuc, ten files:
CreateArrayPaths pthFolder, extFile
If UBound(arPath) = 0 Then GoTo EXIT_MAIN
''Lay du lieu tu sheet tam sang sheet tong hop:
Set Rng = ws.Range("A1:X" & maxR)
maxC = Rng.Columns.Count
For i = 1 To UBound(arPath)
CopyDataFiles Rng, sName, i, arr
CopyData Sheet1, arr, maxC
Next i
EXIT_MAIN:
''Xoa sheet tam:
ws.Delete
Erase arr: Erase arPath
SpeedOn False
End Sub
Sub CopyData(ByVal ws As Worksheet, ByVal arr, ByVal maxC As Long)
Dim lRow As Long, eRow As Long
lRow = UBound(arr, 1)
With ws
eRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & eRow).Resize(lRow, maxC).Value = arr
End With
End Sub
Rem L窕 du li黏 v瀰 sheet temp:
Sub CopyDataFiles(ByVal Rng As Range, ByVal sName As String, ByVal IndxFile As Long, ByRef arr)
Set member_Book = Workbooks.Open(arPath2(IndxFile))
Range("A1:X" & maxR).Copy
ThisWorkbook.Activate
ActiveSheet.Paste
With Rng
arr = .Resize(.Cells(.Rows.Count, 1).End(xlUp).Row).Value
.ClearContents
End With
member_Book.Close False
End Sub
Function GetPathFolder(ByVal pathFolder As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = pathFolder
If .Show Then GetPathFolder = .SelectedItems(1)
End With
End Function
Rem L窕 danh s當h duong d穗 files c穗 tg hop:
Sub CreateArrayPaths(ByVal pathFolder As String, ByVal extFile As String)
Dim FSo As Object, objFolder As Object, objFile As Object, i As Long, wbName As String, iName As String
Set FSo = CreateObject("Scripting.FileSystemObject")
If pathFolder = "" Then Exit Sub
Set objFolder = FSo.GetFolder(pathFolder)
extFile = VBA.UCase(extFile)
wbName = ThisWorkbook.Name
For Each objFile In objFolder.Files
If CheckFileType(FSo.GetExtensionName(objFile)) Then
iName = objFile.Name
If iName <> wbName Then
i = i + 1
ReDim Preserve arPath(1 To i)
ReDim Preserve arPath2(1 To i)
arPath(i) = "'" & pathFolder & "\[" & objFile.Name & "]"
arPath2(i) = pathFolder & "\" & objFile.Name
End If
End If
Next objFile
End Sub
Private Sub AddTempSheet()
On Error Resume Next
If Len(Sheets(wsName)) > 0 Then
Sheets(wsName).Delete
Sheets.Add After:=Sheets(1)
Sheets(2).Name = wsName
Else
Sheets.Add After:=Sheets(1)
Sheets(2).Name = wsName
End If
End Sub
Sub SpeedOn(ByVal sType As Boolean)
With Application
If sType = True Then
.ScreenUpdating = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.DisplayAlerts = True
End If
End With
End Sub
Function CheckFileType(Ftype As String) As Boolean
CheckFileType = False
For i = 0 To UBound(ArrType) - 1
If UCase(Ftype) Like UCase(ArrType(i)) Then
CheckFileType = True
Exit Function
End If
Next i
End Function
