Option Explicit
Dim destSht As Worksheet
Sub Get_Folder_Path()
Dim Folder As String
Folder = Application.GetOpenFilename()
Folder = Left(Folder, Len(Folder) - Len(Split(Folder, "\")(UBound(Split(Folder, "\")))))
On Error Resume Next
If Folder = "" Then Exit Sub
On Error GoTo 0
Call Grab_Raw_Data(Folder)
End Sub
Sub Grab_Raw_Data(Optional FolderPath As String)
Dim FilePath As String
Dim wbook As Workbook
Dim FirstRow As Long, LastRow As Long, FileCount As Integer
Dim strFileArray
Dim lngLoop As Long, x As Long, SkipBook As Boolean, rngCel As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set destSht = ThisWorkbook.Sheets(1)
With destSht
.AutoFilterMode = False
.Columns.Hidden = False
End With
FileCount = 0
'assign the file names to an array - uses FileList function
strFileArray = FileList(FolderPath, "*.xls*")
'Loop through the file names
For x = 0 To UBound(strFileArray)
FilePath = FolderPath & strFileArray(x)
SkipBook = False
On Error Resume Next
Set wbook = Workbooks(Replace(FilePath, FolderPath, ""))
If Not wbook Is Nothing Then
Workbooks(Replace(FilePath, FolderPath, "")).Close False
End If
On Error GoTo 0
On Error GoTo BadWorkbook
Workbooks.Open Filename:=FilePath, ReadOnly:=True
Set wbook = Workbooks(Replace(FilePath, FolderPath, ""))
On Error GoTo 0
FirstRow = 2
LastRow = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
'fill in workbook name and row # to serve as unique identifiers
Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).Resize(LastRow - 1).Value = wbook.FullName
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Value = "Source Book"
Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).Resize(LastRow - 1).Formula = "=Row()"
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Value = "Row #"
ActiveSheet.Calculate
For Each rngCel In Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
rngCel.Value = Trim(rngCel.Value)
Next
SetDestSht
If LastRow <= 2 Then
SkipBook = True
Application.ScreenUpdating = True
MsgBox "'" & Replace(FilePath, FolderPath, "") & "' contains data. It is being skipped.", _
vbInformation, "Skipping " & Replace(FilePath, FolderPath, "")
Application.ScreenUpdating = False
End If
If SkipBook = False Then
Sheets(1).Range(FirstRow & ":" & LastRow).Copy
'paste the data
With destSht
.Range("A" & .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial Paste:=xlPasteFormats
.Range("A" & .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial Paste:=xlPasteValues
FileCount = FileCount + 1
End With
'close the current xls file
Application.CutCopyMode = False
wbook.Close False
End If
Next
For Each destSht In ThisWorkbook.Sheets
destSht.Range("1:1").AutoFilter
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Range("A2").Select
'Tell the user the result
MsgBox "Data was successfully extracted from " & FileCount & " files.", vbOKOnly, "Extraction Complete"
Exit Sub
BadWorkbook: MsgBox "Cannot open """ & Replace(FilePath, FolderPath, "") & """" & vbCrLf & vbCrLf & _
"Please delete all collected data, fix this file or eliminate it, then try again.", vbCritical, "Failure"
With ThisWorkbook.Sheets(1)
.Range("2:" & .Rows.Count).ClearContents
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub SetDestSht()
Dim testSht As Worksheet, prevBk As Workbook
Set destSht = ThisWorkbook.Sheets(1)
Set prevBk = ActiveWorkbook
'Fill header values if not filled already
If Application.WorksheetFunction.CountA(destSht.Range("1:1")) = 0 Then
Sheets(1).Range("1:1").Copy
destSht.Range("A1").PasteSpecial Paste:=xlPasteValues
Exit Sub
End If
For Each testSht In ThisWorkbook.Sheets
If Join(Application.Transpose(Application.Transpose(Range("1:1"))), ",") = _
Join(Application.Transpose(Application.Transpose(testSht.Range("1:1"))), ",") _
Then
Set destSht = testSht
Exit Sub
End If
Next
ThisWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set destSht = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
destSht.Cells.Delete
ActiveSheet.UsedRange
prevBk.Activate
Sheets(1).Range("1:1").Copy
destSht.Range("A1").PasteSpecial Paste:=xlPasteValues
End Sub
Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0
End Function
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & fltr)
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
