Equine Investor
Board Regular
- Joined
- Nov 20, 2002
- Messages
- 103
Hi everyone,
I have obtained a macro off this board to import multiple files and paste them in the one workbook.
The files I am trying to import are all named differently and are actually dbf files.
Is it possible to modify the macro below, so that in Column A contains the filename of each file?
So if the filename is walton2266.dbf, then column A will have walton2266 in every row until the filename changes so it matches the imported data?
Option Explicit
Sub CombineFilesToNewBook()
'
Dim varFilenames As Variant
Dim strActiveBook As String
Dim strSourceDataFile As String
Dim wSht As Worksheet
Dim allwShts As Sheets
Dim intResponse As Integer
Dim counter As Integer
Dim lRows As Long
'
intResponse = MsgBox("This macro will combine all data from all worksheets" & vbCrLf & "from all selected files to a single worksheet in a new workbook. Continue?", vbOKCancel, "Combine Files")
If intResponse = vbOK Then
Workbooks.Add
strActiveBook = ActiveWorkbook.Name
' Create array of filenames; the True is for multi-select
On Error GoTo exitsub
varFilenames = Application.GetOpenFilename(, , , , True)
counter = 1
' ubound determines how many items in the array
On Error GoTo quit
Application.ScreenUpdating = False
While counter <= UBound(varFilenames)
'Opens the selected files
Workbooks.Open varFilenames(counter)
strSourceDataFile = ActiveWorkbook.Name
Set allwShts = Worksheets
For Each wSht In allwShts
' Select Entire UsedRange from Source File
wSht.Activate
ActiveSheet.UsedRange.Select
Selection.Copy
' Find end of usedrange in destination file
Workbooks(strActiveBook).Activate
Range("A1").Select
ActiveSheet.UsedRange.Select
lRows = Selection.Rows.Count
ActiveCell.Offset(lRows, 0).Select
' Copy & Paste All including Formatting
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Next wSht
Workbooks(strSourceDataFile).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
' displays file name in a message box
MsgBox varFilenames(counter) & " Has Been Processed", vbOKOnly + vbInformation, "File Processed"
'increment counter
counter = counter + 1
Wend
quit:
If Err <> 0 Then
MsgBox "An Error Occurred Trying to open the File. Please close any open Excel files and try again", vbOKOnly + vbExclamation, "File Open Error"
On Error GoTo 0
End If
End If
exitsub:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I have obtained a macro off this board to import multiple files and paste them in the one workbook.
The files I am trying to import are all named differently and are actually dbf files.
Is it possible to modify the macro below, so that in Column A contains the filename of each file?
So if the filename is walton2266.dbf, then column A will have walton2266 in every row until the filename changes so it matches the imported data?
Option Explicit
Sub CombineFilesToNewBook()
'
Dim varFilenames As Variant
Dim strActiveBook As String
Dim strSourceDataFile As String
Dim wSht As Worksheet
Dim allwShts As Sheets
Dim intResponse As Integer
Dim counter As Integer
Dim lRows As Long
'
intResponse = MsgBox("This macro will combine all data from all worksheets" & vbCrLf & "from all selected files to a single worksheet in a new workbook. Continue?", vbOKCancel, "Combine Files")
If intResponse = vbOK Then
Workbooks.Add
strActiveBook = ActiveWorkbook.Name
' Create array of filenames; the True is for multi-select
On Error GoTo exitsub
varFilenames = Application.GetOpenFilename(, , , , True)
counter = 1
' ubound determines how many items in the array
On Error GoTo quit
Application.ScreenUpdating = False
While counter <= UBound(varFilenames)
'Opens the selected files
Workbooks.Open varFilenames(counter)
strSourceDataFile = ActiveWorkbook.Name
Set allwShts = Worksheets
For Each wSht In allwShts
' Select Entire UsedRange from Source File
wSht.Activate
ActiveSheet.UsedRange.Select
Selection.Copy
' Find end of usedrange in destination file
Workbooks(strActiveBook).Activate
Range("A1").Select
ActiveSheet.UsedRange.Select
lRows = Selection.Rows.Count
ActiveCell.Offset(lRows, 0).Select
' Copy & Paste All including Formatting
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Next wSht
Workbooks(strSourceDataFile).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
' displays file name in a message box
MsgBox varFilenames(counter) & " Has Been Processed", vbOKOnly + vbInformation, "File Processed"
'increment counter
counter = counter + 1
Wend
quit:
If Err <> 0 Then
MsgBox "An Error Occurred Trying to open the File. Please close any open Excel files and try again", vbOKOnly + vbExclamation, "File Open Error"
On Error GoTo 0
End If
End If
exitsub:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub