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 ConsolidateInDifferntSheet()
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" 'Change to suit
strThisWkb = ThisWorkbook.Name
'strConsTab = "Sheet1" 'Change to suit
' Sheets.Add.Name = MyNewSheet.Value
'MyNames.Worksheet.Select
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDir)
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
Workbooks(strThisWkb).Sheets.Add.Name = Split(objFile.Name, ".")(0)
strConsTab = Split(objFile.Name, ".")(0)
'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
'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
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
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
Workbooks.Open Filename:=strDir & "\" & objFile.Name
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
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.
'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 ConsolidateInDifferntSheet()
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" 'Change to suit
strThisWkb = ThisWorkbook.Name
'strConsTab = "Sheet1" 'Change to suit
' Sheets.Add.Name = MyNewSheet.Value
'MyNames.Worksheet.Select
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDir)
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
Workbooks(strThisWkb).Sheets.Add.Name = Split(objFile.Name, ".")(0)
strConsTab = Split(objFile.Name, ".")(0)
'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
'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
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
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
Workbooks.Open Filename:=strDir & "\" & objFile.Name
rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
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.
'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