J
JakeShipley2008
I got some help off here this morning hoping for some more. The following
macro works to pull in multiple files, I have 2 problems with it.
1) If I select 4 files it will only pull in 3
2) it additionally creates multiple new files containing the same data.
Thanks in advance,
Sub CombineExcelFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = ","
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="excel Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=False, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Copy Before:=ThisWorkbook.Sheets(Sheets.count)
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=False, OtherChar:=sDelimiter
End With
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
macro works to pull in multiple files, I have 2 problems with it.
1) If I select 4 files it will only pull in 3
2) it additionally creates multiple new files containing the same data.
Thanks in advance,
Sub CombineExcelFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = ","
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="excel Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=False, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Copy Before:=ThisWorkbook.Sheets(Sheets.count)
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=False, OtherChar:=sDelimiter
End With
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub