excel vba import file utility

B

bryanrobson

New Member
Joined
Aug 19, 2022
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hi everyone.

I'm looking for code to prompt for a folder where the files are located (mutliple XLS files) and then merge them all into one sheet. For any columns which are numbers and have leading 0's, I want to preserve the leading zeros. Other fields could be text or currency or dates and again, I want the import to merge all the data into one spreadsheet basically maintaining the format in the source files.

Many thanks
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
Can you clarify what you are trying to achieve by merging them? Are you trying to merge them all into one sheet? Are all the column headers identical and in the same order?
 
Upvote 0
breynolds0431 said:
Can you clarify what you are trying to achieve by merging them? Are you trying to merge them all into one sheet? Are all the column headers identical and in the same order?
Click to expand...

hiya

I was just wondering if it was possible to have a generic import tool. So, the multiple files, which are all the same. same number of columns and the same data / column type such as text, dates, currency in the same positions. But then the tool can be tweaked if i'm importing another set of different files. The end result being merged into one sheet.

thanks
Darren.
 
Upvote 0
breynolds0431 said:
Can you clarify what you are trying to achieve by merging them? Are you trying to merge them all into one sheet? Are all the column headers identical and in the same order?
Click to expand...

I have found the below code on the internet.

It prompts you for the folder where all the files you want to import live. it imports all the files onto one sheet. It basically does what I want except it doesnt preserve the format of numbers with leading zeros. If you know how to change that, then it will be perfect.

Thanks







Sub Merge()

Dim it, ar
Dim cell As Range
Dim sht As Worksheet


' this deletes the sheet from the last time it was run
For Each sht In ThisWorkbook.Worksheets
If sht.Name Like "Merged Results" Then
Sheets("Merged Results").Delete
End If
Next sht


Sheets.Add.Name = "Merged Results" 'adds new sheet
Worksheets("Merged Results").Activate 'sets focus on new sheet



'prompts for folder of location of files to merge
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
For Each it In CreateObject("scripting.filesystemobject").getfolder(.SelectedItems(1)).Files
If it Like "*XLS*" Then
With GetObject(it).Sheets(1)
ar = .UsedRange.Value
ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Resize(UBound(ar), UBound(ar, 2)) = ar
.Parent.Close 0
End With
End If
Next
End If
End With



End Sub
 
Upvote 0
Hi. Give this a try. This method will copy all rows and columns from each sheet into a sheet called Merge (variable "mrg"). It finds the last column of the sheets to be imported/merged, so it should work with any changes to the import files (as long as all import files are identical in columns) and not require any tweaking to the code itself.

Let me know how it does with your formatting. I tested some leading zeros formatted as text and it worked as expected.

VBA Code: 
Sub ImportFiles()

'declare Active tWB and Merge tab
Dim tWB As Workbook: Set tWB = ThisWorkbook

'this will be the name for your merge sheet change
'"Merge" to whatever you'd like the sheet to be
Dim mrg As String: mrg = "Merge"

'checks if mrg sheet exists, will delete if true
If WSExists(mrg) Then
    'Merge exists, so delete it
    Application.DisplayAlerts = False
    tWB.Sheets("Merge").Delete
    Application.DisplayAlerts = True
End If

'creates new Merge sheet
Dim tWS As Worksheet: Set tWS = tWB.Sheets.Add(After:=tWB.Worksheets(tWB.Worksheets.Count))
tWS.Name = mrg

'declares folder picker as a variable
Dim fldPick As FileDialog: Set fldPick = Application.FileDialog(msoFileDialogFolderPicker)

With fldPick
    .AllowMultiSelect = False
    .Title = "Select the File Folder"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
End With

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath to select all Excel files
Dim iFolder As String: iFolder = fldPick.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim xWB As Workbook, xLRow As Long, xLCol As Integer, tLRow As Long
Dim cnt As Integer: cnt = 0

'loop through each excel file in iPath
Do While iFile <> ""
    Set xWB = Workbooks.Open(FileName:=iFolder & iFile, ReadOnly:=True)
    DoEvents
    
    With xWB.Sheets(1)
        If tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row = 1 Then
        'merge sheet is blank, so copy header row with first import sheet
            .Cells(1, 1).CurrentRegion.Copy
            
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Else
        'merge sheet is not blank (thus, has header row already), so copy
        'only the import file's data without header row
            
            'determines last row and column of import sheet
            xLRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            xLCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            'determines last row of merge sheet
            tLRow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
            
            'copies and pastes data
            .Range(.Cells(2, 1), .Cells(xLRow, xLCol)).Copy
            
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(tLRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
            
        End If
        'count used in task completion message
        cnt = cnt + 1
    End With
    
    DoEvents
    'turn off alerts for clipboard message before xWB.close
    Application.DisplayAlerts = False
    xWB.Close savechanges:=False
    Application.DisplayAlerts = True
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "There were " & cnt & " files successfully imported to the merge sheet." _
        , vbInformation + vbOKOnly, "Files Imported"
        
Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
    
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
    
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
 
Upvote 0
breynolds0431 said:
Hi. Give this a try. This method will copy all rows and columns from each sheet into a sheet called Merge (variable "mrg"). It finds the last column of the sheets to be imported/merged, so it should work with any changes to the import files (as long as all import files are identical in columns) and not require any tweaking to the code itself.

Let me know how it does with your formatting. I tested some leading zeros formatted as text and it worked as expected.

VBA Code: 
Sub ImportFiles()

'declare Active tWB and Merge tab
Dim tWB As Workbook: Set tWB = ThisWorkbook

'this will be the name for your merge sheet change
'"Merge" to whatever you'd like the sheet to be
Dim mrg As String: mrg = "Merge"

'checks if mrg sheet exists, will delete if true
If WSExists(mrg) Then
    'Merge exists, so delete it
    Application.DisplayAlerts = False
    tWB.Sheets("Merge").Delete
    Application.DisplayAlerts = True
End If

'creates new Merge sheet
Dim tWS As Worksheet: Set tWS = tWB.Sheets.Add(After:=tWB.Worksheets(tWB.Worksheets.Count))
tWS.Name = mrg

'declares folder picker as a variable
Dim fldPick As FileDialog: Set fldPick = Application.FileDialog(msoFileDialogFolderPicker)

With fldPick
    .AllowMultiSelect = False
    .Title = "Select the File Folder"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
End With

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath to select all Excel files
Dim iFolder As String: iFolder = fldPick.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim xWB As Workbook, xLRow As Long, xLCol As Integer, tLRow As Long
Dim cnt As Integer: cnt = 0

'loop through each excel file in iPath
Do While iFile <> ""
    Set xWB = Workbooks.Open(FileName:=iFolder & iFile, ReadOnly:=True)
    DoEvents
   
    With xWB.Sheets(1)
        If tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row = 1 Then
        'merge sheet is blank, so copy header row with first import sheet
            .Cells(1, 1).CurrentRegion.Copy
           
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Else
        'merge sheet is not blank (thus, has header row already), so copy
        'only the import file's data without header row
           
            'determines last row and column of import sheet
            xLRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            xLCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            'determines last row of merge sheet
            tLRow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
           
            'copies and pastes data
            .Range(.Cells(2, 1), .Cells(xLRow, xLCol)).Copy
           
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(tLRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
           
        End If
        'count used in task completion message
        cnt = cnt + 1
    End With
   
    DoEvents
    'turn off alerts for clipboard message before xWB.close
    Application.DisplayAlerts = False
    xWB.Close savechanges:=False
    Application.DisplayAlerts = True
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "There were " & cnt & " files successfully imported to the merge sheet." _
        , vbInformation + vbOKOnly, "Files Imported"
       
Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
   
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
   
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
Click to expand...
Hiya. Thanks very much for the reply. Depending on what files I am working with the main headings are not on row 1. they could be on row 5 or 6 or 7 as there are header records in each file.
So, because there is just a header in column A, its taking that as the last column. If I delete the headers to leave the headings on row1 it works perfectly. If there is any chance you can tweak it to deal with the variation on where the headers start that would be great.

Thanks
 
Upvote 0
Is there any sheet information prior to where the data begins? The below will use the .UsedRange to identify where the data begins. But, using the UsedRange will also pick up cells outside of the main dataset, which would throw off what's copied.

Let me know how that works.

VBA Code: 
Sub ImportFiles()

'declare Active tWB and Merge tab
Dim tWB As Workbook: Set tWB = ThisWorkbook

'this will be the name for your merge sheet change
'"Merge" to whatever you'd like the sheet to be
Dim mrg As String: mrg = "Merge"

'checks if mrg sheet exists, will delete if true
If WSExists(mrg) Then
    'Merge exists, so delete it
    Application.DisplayAlerts = False
    tWB.Sheets("Merge").Delete
    Application.DisplayAlerts = True
End If

'creates new Merge sheet
Dim tWS As Worksheet: Set tWS = tWB.Sheets.Add(After:=tWB.Worksheets(tWB.Worksheets.Count))
tWS.Name = mrg

'declares folder picker as a variable
Dim fldPick As FileDialog: Set fldPick = Application.FileDialog(msoFileDialogFolderPicker)

With fldPick
    .AllowMultiSelect = False
    .Title = "Select the File Folder"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
End With

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath to select all Excel files
Dim iFolder As String: iFolder = fldPick.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim xWB As Workbook, xLRow As Long, xLCol As Integer, tLRow As Long
Dim cnt As Integer: cnt = 0

'loop through each excel file in iPath
Do While iFile <> ""
    Set xWB = Workbooks.Open(Filename:=iFolder & iFile, ReadOnly:=True)
    DoEvents
    
    With xWB.Sheets(1)
        If tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row = 1 Then
        'merge sheet is blank, so copy header row with first import sheet - updated to use .UsedRange
            .UsedRange.Copy
            
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Else
        'merge sheet is not blank (thus, has header row already), so copy
        'only the import file's data without header row
            
            'determines last row and column of import sheet
            xLRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            xLCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            'determines last row of merge sheet
            tLRow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
            
            'copies and pastes data - updated to use .UsedRange
            .UsedRange.Offset(1).Resize(.UsedRange.Rows.Count - 1).Copy
            
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(tLRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
            
        End If
        'count used in task completion message
        cnt = cnt + 1
    End With
    
    DoEvents
    'turn off alerts for clipboard message before xWB.close
    Application.DisplayAlerts = False
    xWB.Close savechanges:=False
    Application.DisplayAlerts = True
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "There were " & cnt & " files successfully imported to the merge sheet." _
        , vbInformation + vbOKOnly, "Files Imported"
        
Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
    
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
    
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
 
Upvote 0
Solution
breynolds0431 said:
Is there any sheet information prior to where the data begins? The below will use the .UsedRange to identify where the data begins. But, using the UsedRange will also pick up cells outside of the main dataset, which would throw off what's copied.

Let me know how that works.

VBA Code: 
Sub ImportFiles()

'declare Active tWB and Merge tab
Dim tWB As Workbook: Set tWB = ThisWorkbook

'this will be the name for your merge sheet change
'"Merge" to whatever you'd like the sheet to be
Dim mrg As String: mrg = "Merge"

'checks if mrg sheet exists, will delete if true
If WSExists(mrg) Then
    'Merge exists, so delete it
    Application.DisplayAlerts = False
    tWB.Sheets("Merge").Delete
    Application.DisplayAlerts = True
End If

'creates new Merge sheet
Dim tWS As Worksheet: Set tWS = tWB.Sheets.Add(After:=tWB.Worksheets(tWB.Worksheets.Count))
tWS.Name = mrg

'declares folder picker as a variable
Dim fldPick As FileDialog: Set fldPick = Application.FileDialog(msoFileDialogFolderPicker)

With fldPick
    .AllowMultiSelect = False
    .Title = "Select the File Folder"
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
End With

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo ResetSettings

'set up loop through iPath to select all Excel files
Dim iFolder As String: iFolder = fldPick.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim xWB As Workbook, xLRow As Long, xLCol As Integer, tLRow As Long
Dim cnt As Integer: cnt = 0

'loop through each excel file in iPath
Do While iFile <> ""
    Set xWB = Workbooks.Open(Filename:=iFolder & iFile, ReadOnly:=True)
    DoEvents
   
    With xWB.Sheets(1)
        If tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row = 1 Then
        'merge sheet is blank, so copy header row with first import sheet - updated to use .UsedRange
            .UsedRange.Copy
           
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        Else
        'merge sheet is not blank (thus, has header row already), so copy
        'only the import file's data without header row
           
            'determines last row and column of import sheet
            xLRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            xLCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            'determines last row of merge sheet
            tLRow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
           
            'copies and pastes data - updated to use .UsedRange
            .UsedRange.Offset(1).Resize(.UsedRange.Rows.Count - 1).Copy
           
            'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
            tWS.Cells(tLRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
           
        End If
        'count used in task completion message
        cnt = cnt + 1
    End With
   
    DoEvents
    'turn off alerts for clipboard message before xWB.close
    Application.DisplayAlerts = False
    xWB.Close savechanges:=False
    Application.DisplayAlerts = True
    iFile = Dir
Loop

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "There were " & cnt & " files successfully imported to the merge sheet." _
        , vbInformation + vbOKOnly, "Files Imported"
       
Exit Sub

'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function WSExists(SheetName As String) As Boolean
   
Dim TempSheetName As String

TempSheetName = UCase(SheetName)

WSExists = False
   
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
        WSExists = True
        Exit Function
    End If
Next Sheet

End Function
Click to expand...

Hi BReynolds0431

That is absolutely spot on.

Thanks a lot. Much appreciated.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
228
MountainFog
M
J
  • Question
VBA to clear all date in columns A2 to AC in the destination file, then copy the data from the same columns from all files in a folder
Replies
1
Views
99
jdhfch
J
S
  • Question
VBA import of an IQY file without prompt
Replies
4
Views
358
John_w
J
H
  • Solved
Excel VBA file importing data from several files located in same folder -> challenge to copy data only (rest is working perfectly)
Replies
3
Views
132
NdNoviceHlp
NdNoviceHlp
C
  • Question
Multiple Workbooks to one.
2
Replies
11
Views
548
dmt32
D

Forum statistics

Threads
1,214,858
Messages
6,121,956
Members
449,057
Latest member
FreeCricketId

Share this page

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