Multiple file import plus filename

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
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
..worked once, no real testing..

Code:
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

wSht.Activate
'add filename in column A
lRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:A" & lRows).Select
Selection.Insert Shift:=xlToRight
Range("A1:A" & lRows).Value = strSourceDataFile

' Select Entire UsedRange from Source File
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
 
Upvote 0

Forum statistics

Threads
1,214,983
Messages
6,122,592
Members
449,089
Latest member
Motoracer88

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top