Public Function IsFileOpen(strFileName As String) As Boolean
On Error Resume Next 'Ignore any errors (i.e. if workbook is not open)
Set wrkFileName = Workbooks(strFileName)
If wrkFileName Is Nothing Then
IsFileOpen = False
Else
IsFileOpen = True
End If
On Error GoTo 0 'Nullify above error handler
End Function
Sub ConsolidateInSingleSheet()
Dim strDir As String, _
strThisWkb As String, _
strConsTab As String
Dim objFSO As Object, _
objFolder As Object, _
objFile As Object
Dim lngPasteRow As Long
strDir = "D:\Source Excel" ' can be Change
strThisWkb = ThisWorkbook.Name
strConsTab = "Sheet1" ' can be Change
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDir)
Application.ScreenUpdating = False
'Clear any existing data.
lngPasteRow = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & lngPasteRow).ClearContents
For Each objFile In objFolder.Files
'If the file in the 'strDir' directory is not this workbook, then...
Dim LastrowDes As Double
Dim rowCountSource As Double
If objFile.Name <> strThisWkb Then
'...check to see if it's open. If it is...
If IsFileOpen(objFile.Name) = True Then
LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
'...set the 'lngPasteRow' variable. If this value is 2, then...
lngPasteRow = _
Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
If lngPasteRow = 2 Then
'...link the entire range (i.e. headings + data) as this is the first file being imported.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
'Else...
Else
'...only link the data range.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
End If
'Else, set the 'lngPasteRow' variable and open the workbook.
Else
LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
lngPasteRow = _
Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
Workbooks.Open Filename:=strDir & "\" & objFile.Name
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
'If the 'lngPasteRow' variable value is 2, then...
If lngPasteRow = 2 Then
'...link the entire range (i.e. headings + data) as this is the first file being imported.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
'Else...
Else
'...only link the data range.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
End If
'Close the just opened file without saving any changes to it.
Workbooks(objFile.Name).Close False
End If
End If
'Release memory
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
Next objFile
Application.ScreenUpdating = True
MsgBox "Data from each workbook in the """ & strDir & """ directory has now been imported to the """ & strConsTab & """ tab.", vbInformation, "Import Data Editor"
End Sub
On Error Resume Next 'Ignore any errors (i.e. if workbook is not open)
Set wrkFileName = Workbooks(strFileName)
If wrkFileName Is Nothing Then
IsFileOpen = False
Else
IsFileOpen = True
End If
On Error GoTo 0 'Nullify above error handler
End Function
Sub ConsolidateInSingleSheet()
Dim strDir As String, _
strThisWkb As String, _
strConsTab As String
Dim objFSO As Object, _
objFolder As Object, _
objFile As Object
Dim lngPasteRow As Long
strDir = "D:\Source Excel" ' can be Change
strThisWkb = ThisWorkbook.Name
strConsTab = "Sheet1" ' can be Change
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDir)
Application.ScreenUpdating = False
'Clear any existing data.
lngPasteRow = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & lngPasteRow).ClearContents
For Each objFile In objFolder.Files
'If the file in the 'strDir' directory is not this workbook, then...
Dim LastrowDes As Double
Dim rowCountSource As Double
If objFile.Name <> strThisWkb Then
'...check to see if it's open. If it is...
If IsFileOpen(objFile.Name) = True Then
LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
'...set the 'lngPasteRow' variable. If this value is 2, then...
lngPasteRow = _
Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
If lngPasteRow = 2 Then
'...link the entire range (i.e. headings + data) as this is the first file being imported.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
'Else...
Else
'...only link the data range.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
End If
'Else, set the 'lngPasteRow' variable and open the workbook.
Else
LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
lngPasteRow = _
Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
Workbooks.Open Filename:=strDir & "\" & objFile.Name
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
'If the 'lngPasteRow' variable value is 2, then...
If lngPasteRow = 2 Then
'...link the entire range (i.e. headings + data) as this is the first file being imported.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
'Else...
Else
'...only link the data range.
Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
End If
'Close the just opened file without saving any changes to it.
Workbooks(objFile.Name).Close False
End If
End If
'Release memory
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
Next objFile
Application.ScreenUpdating = True
MsgBox "Data from each workbook in the """ & strDir & """ directory has now been imported to the """ & strConsTab & """ tab.", vbInformation, "Import Data Editor"
End Sub
No comments:
Post a Comment