Merge Data from Multiple Workbooks into One

C

CDThe1

New Member
Joined
Mar 27, 2016
Messages
12
Hello, I have seen variations of this question, but nothing that fits for me. Here's what I want.

I have a "master" file and about 50 source files I want to extract data from. (I just want to copy one column or range from the source files). I need a VBA that will open the source file "ABC" with one sheet named "1000" and paste in into the "master" file in a sheet with the same name. The next source file is "XYZ" with one sheet named "1200" and copy it in the master file on sheet "1200."

The trouble is, the source filenames will change from one month to the next., so I would need to reference a specific cell for the correct filename to use.

Hope that makes sense.

Thanks in advance.
 
Sort by date Sort by votes

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
maabadi said:
3. Then What is Destination Range for Pasting Values?
Click to expand...
He said the positive. He does want to override. So that is the destination range. But even if it's not, he can easily change the argument that's passed in the top-most sub of my code.
 
Upvote 0
This is another option:
VBA Code: 
Sub ImportFiles()
Dim wbOpen As Workbook, strPath As String, Lr As Integer, FolderName As String
Dim xStrPath As String, xStrName As String, xStrFName As String, Arr() As String
Dim xWS As Worksheet, xTWB As Workbook, xStrAWBName As String, Z As Integer, i As Integer
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each xWS In xTWB.Worksheets
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = xWS.Name
Next xWS
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Z = Application.Match(xWS.Name, Arr, False)
Lr = xWS.Range("C" & Rows.Count).End(xlUp).Row
If Z > 0 And Lr > 1 Then
xTWB.Sheets(Z - 1).Range("C10:C" & Lr).Value = xWS.Range("C10:C" & Lr).Value
Z = 0
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
maabadi said:
This is another option:
VBA Code: 
Lr = xWS.Range("C" & Rows.Count).End(xlUp).Row
If Z > 0 And Lr > 1 Then
xTWB.Sheets(Z - 1).Range("C10:C" & Lr).Value = xWS.Range("C10:C" & Lr).Value
Click to expand...
But if there is data in Column C in the source files below Row 256, this code puts that into the master Workbook (which is not what he wanted). It's easy to fix though.

But yeah, I could have added Application.ScreenUpdating to the test sub to make it less jumpy (but I thought it looked cool to jump like that).
VBA Code: 
Sub Test__Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet()

Application.ScreenUpdating = False
Call Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet( _
ThisWorkbook.Sheets("Data Retrieval Sheet").Range("A2").Value & "\", ".xlsx", _
"Data Retrieval Sheet", _
"C10:C256" _
)
Application.ScreenUpdating = True

End Sub

Your code runs about twice as fast as mine too. (4 seconds instead of 8) I guess it's good to see both coding styles. (Obviously I write code expanded and separated into modules rather than tailor and condense it.)
 
Upvote 0
maabadi said:
This is another option:
VBA Code: 
Sub ImportFiles()
Dim wbOpen As Workbook, strPath As String, Lr As Integer, FolderName As String
Dim xStrPath As String, xStrName As String, xStrFName As String, Arr() As String
Dim xWS As Worksheet, xTWB As Workbook, xStrAWBName As String, Z As Integer, i As Integer
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each xWS In xTWB.Worksheets
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = xWS.Name
Next xWS
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Z = Application.Match(xWS.Name, Arr, False)
Lr = xWS.Range("C" & Rows.Count).End(xlUp).Row
If Z > 0 And Lr > 1 Then
xTWB.Sheets(Z - 1).Range("C10:C" & Lr).Value = xWS.Range("C10:C" & Lr).Value
Z = 0
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Click to expand...
This works perfectly. Thank you so much.
 
Upvote 0
cmowla said:
I have just finished this mini project. I am going to upload a video explaining it after I post this.

But basically,
  1. Create a new sheet in your master workbook named "Data Retrieval Sheet" (without quotes).
  2. Copy and paste the folder path (for example, "C:\Users\Chris\Desktop\Source Files" (without quotes) ) and paste that into Cell A2 in the "Data Retrieval Sheet".
  3. Put the below code into a new standard VBA code module.
  4. Run the top-most sub in this code.

  • Note that this assumes that all of the source files are of file extension .xlsx.
  • If there is a mixture of .xls and .xlsx, this will code will NOT work properly. (It needs to be either all .xls or .xlsx. If all are .xls, then you need to change the argument ".xlsx" in the top-most sub to ".xls".)

VBA Code: 
Option Explicit

Sub Test__Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet()
Call Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet( _
ThisWorkbook.Sheets("Data Retrieval Sheet").Range("A2").Value & "\", ".xlsx", _
"Data Retrieval Sheet", _
"C10:C256" _
)
End Sub
Sub Get_All_Source_File_Names_With_This_File_Extension_From_This_FolderPath_Along_With_All_Of_Their_Sheet_Names_And_Put_Them_Into_A_Directory_Table_In_This_Sheet( _
folderPath As String, _
desiredFileExtension As String, _
sheetWithDirectoryTable As String, _
rangeToCopyValuesFromEachSheet As String _
)

'This sub takes the folder path such that there is no "\" at the end.  If there is one, it's omitted.
If SubString(folderPath, Len(folderPath), Len(folderPath)) = "\" Then folderPath = SubString(folderPath, 1, Len(folderPath) - 1)

'-----------------------------------------------------------
'Create a Table of Directories in this Master Excel Workbook
'-----------------------------------------------------------
    With ThisWorkbook.Sheets(sheetWithDirectoryTable)
        .UsedRange.Value = ""
        .Range("A1").Value = "Folder Path of Source Files"
        .Range("A1").RowHeight = 50
        .Range("A1").WrapText = True
        .Range("A1").ColumnWidth = 50
        .Range("A2").Value = folderPath 'put the folder path name back for the future.
        .Range("B3").ColumnWidth = 50
        .Range("B3").Value = "Master File Name"
        .Range("B4") = ThisWorkbook.Name
        .Range("B5").Value = "Master File's Sheets:"
        .Range("B5").Font.Bold = True
    End With
 
    Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
    ThisWorkbook, _
    sheetWithDirectoryTable, 6, 2, _
    Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook) _
    )

    Dim currentFileIndexNumber As Integer
    currentFileIndexNumber = 0
 
    Dim book As Workbook
    Dim currentFileExtension As String
    Dim currentFileName As String
    Dim C As Collection 'https://stackoverflow.com/a/28054165
    Dim Filee As Variant
    Set C = GetFilesIn(folderPath)
    For Each Filee In C
        currentFileName = Filee
        currentFileExtension = SubString(currentFileName, InStrRev(currentFileName, "."), Len(currentFileName))
        If desiredFileExtension = currentFileExtension Then
            currentFileName = SubString(currentFileName, InStrRev(currentFileName, "\") + 1, InStrRev(currentFileName, ".") - 1)
            currentFileIndexNumber = currentFileIndexNumber + 1
         
            Set book = Workbooks.Open(fileName:=folderPath & "\" & currentFileName & desiredFileExtension)
 
            Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
            ThisWorkbook, _
            sheetWithDirectoryTable, 6, 2 + currentFileIndexNumber, _
            Return_All_Worksheet_Names_In_This_Excel_File(book) _
            )
 
            With ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, currentFileIndexNumber + 2)
                .Value = book.Name
                .Font.Bold = True
            End With
            book.Close savechanges:=False
            Set book = Nothing
        End If
      
    Next Filee

ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("B2").Formula = "=COUNTA(B3:B1000) + 2" 'It's unlikely an Excel file will have more than 1000 worksheets!
ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2").Formula = "=COUNTA(C3:C1000) + 4"
ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2:" & Column_Number_To_Letter(currentFileIndexNumber + 2) & "2").Formula = ThisWorkbook.Sheets(sheetWithDirectoryTable).Range("C2").Formula


'---------------------------------------------------------------------------------------
'Now search/compare the sheet names of This Workbook to those of the source Excel files'
'---------------------------------------------------------------------------------------
Dim lastRowWithSheetNamesForMasterWorkbook As Integer
lastRowWithSheetNamesForMasterWorkbook = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(2, 2).Value

Dim lastRowWithDataSheetNamesForThisSourceWorkbook As Integer
Dim workbookIsAlreadyOpened As Boolean


Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim sheetNameToUpdate As String
j = 3
Do While j <= currentFileIndexNumber + 2 'This variable is now the total number of source files.  Counter for going across columns.
    lastRowWithDataSheetNamesForThisSourceWorkbook = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(2, j).Value

    k = 6
    Do While k <= lastRowWithDataSheetNamesForThisSourceWorkbook 'Counter for going top to bottom in current source workbook column.
        workbookIsAlreadyOpened = False
        i = 6
        Do While i <= lastRowWithSheetNamesForMasterWorkbook 'Counter for going top to bottom in the master sheet workbook column.
            'Debug.Print j & ": " & lastRowWithDataSheetNamesForThisSourceWorkbook & ": " & k & ": " & i
            If ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(i, 2).Value = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(k, j).Value Then
                sheetNameToUpdate = ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(i, 2).Value
                Debug.Print "Sheet '" & sheetNameToUpdate & "' from the master workbook is in the source Excel file: '" & ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, j).Value & "'"
                If workbookIsAlreadyOpened = False Then
                    Set book = Workbooks.Open(fileName:=folderPath & "\" & ThisWorkbook.Sheets(sheetWithDirectoryTable).Cells(5, j).Value)
                    workbookIsAlreadyOpened = True
                End If
                ThisWorkbook.Sheets(sheetNameToUpdate).Range(rangeToCopyValuesFromEachSheet).Value = book.Sheets(sheetNameToUpdate).Range(rangeToCopyValuesFromEachSheet).Value
            End If
            i = i + 1
        Loop
        If workbookIsAlreadyOpened = True Then book.Close savechanges:=False
        Set book = Nothing

        k = k + 1
    Loop
    j = j + 1
Loop

End Sub




Function GetFilesIn(Folder As String) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
    GetFilesIn.Add F
    F = Dir
Loop
End Function


Sub Test__Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column()
Call Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column( _
ThisWorkbook, _
"Data Retrieval Sheet", 6, 2, _
Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook) _
)
End Sub
Sub Put_This_Array_In_This_Workbook_In_This_Sheet_In_This_Column(book As Workbook, sheetName As String, startRow As Long, columnNumber As Integer, arr As Variant)
Dim i As Long
Dim j As Integer
j = 1
i = startRow
Do While j <= UBound(arr)
    book.Sheets(sheetName).Cells(i, columnNumber).Value = arr(j)
    i = i + 1
    j = j + 1
Loop

End Sub


Sub Test__Return_All_Worksheet_Names_In_This_Excel_File()
MsgBox Return_All_Worksheet_Names_In_This_Excel_File(ThisWorkbook)(1)
End Sub
Function Return_All_Worksheet_Names_In_This_Excel_File(book As Workbook)

ReDim arrayOfSheetNames(0 To 0) As String

Dim sht As Worksheet
For Each sht In book.Sheets
    If (sht.Visible = -1) And (sht.Name <> "Data Retrieval Sheet") Then  'If the sheet is visible in the current workbook,
        arrayOfSheetNames = Append_StringType(arrayOfSheetNames, sht.Name)
        'Debug.Print arrayOfSheetNames(UBound(arrayOfSheetNames))
    End If
Next sht

Return_All_Worksheet_Names_In_This_Excel_File = arrayOfSheetNames

End Function


Sub Test__Append_StringType()

ReDim sampleArray(1 To 2) As String
sampleArray(1) = "item 1"
sampleArray(2) = "item 2"

sampleArray = Append_StringType(sampleArray, "##Address_1 Line 1##")
MsgBox sampleArray(1)
MsgBox sampleArray(2)
End Sub
Function Append_StringType(arr As Variant, arg As Variant)
'Two possible errors from client subs:
'(1) arr is not of type variant.
'(2) arr is defined as Dim array() as Variant instead of ReDim array(1 to x) as variant.

    Dim lowerBOundOfInputArray As Integer
    lowerBOundOfInputArray = LBound(arr)

    Dim upperBoundOfInputArray As Integer
    upperBoundOfInputArray = UBound(arr)

    ReDim newArray(lowerBOundOfInputArray To upperBoundOfInputArray) As String
    newArray = arr
 
    ReDim Preserve newArray(lowerBOundOfInputArray To upperBoundOfInputArray + 1)
    newArray(upperBoundOfInputArray + 1) = arg
 
    Append_StringType = newArray

End Function


Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function


Sub Test__Column_Number_To_Letter()
MsgBox Column_Number_To_Letter(4)
MsgBox Column_Number_To_Letter(44)
End Sub
Function Column_Number_To_Letter(columnNumber As Integer) As String
'From https://stackoverflow.com/questions/12796973/function-to-convert-column-number-to-letter
    Dim vArr
    vArr = Split(Cells(1, columnNumber).Address(True, False), "$")
    Column_Number_To_Letter = vArr(0)
End Function
Click to expand...
Thank you so much.
 
Upvote 0
maabadi said:
This is another option:
VBA Code: 
Sub ImportFiles()
Dim wbOpen As Workbook, strPath As String, Lr As Integer, FolderName As String
Dim xStrPath As String, xStrName As String, xStrFName As String, Arr() As String
Dim xWS As Worksheet, xTWB As Workbook, xStrAWBName As String, Z As Integer, i As Integer
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each xWS In xTWB.Worksheets
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = xWS.Name
Next xWS
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Z = Application.Match(xWS.Name, Arr, False)
Lr = xWS.Range("C" & Rows.Count).End(xlUp).Row
If Z > 0 And Lr > 1 Then
xTWB.Sheets(Z - 1).Range("C10:C" & Lr).Value = xWS.Range("C10:C" & Lr).Value
Z = 0
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Click to expand...
Hi, this works perfectly, but does not import every worksheet.
 
Upvote 0
CDThe1 said:
Hi, this works perfectly, but does not import every worksheet.
Click to expand...
Mine does, correct? And if there is data below row 256 in the source sheets, his will pull in that data into the master workbook (as I pointed out in this post), which is also not what you asked for. So can you please mark my answer and the Solution since I was the one who found out what you specifically wanted and gave you specifically what you asked for?

If mine is simply a little too jumpy, just see the edit I made to the top-most sub in this post.
 
Last edited:
Upvote 0
Solution
cmowla said:
Mine does, correct? And if there is data below row 256 in the source sheets, his will pull in that data into the master workbook, which is also not what you asked for. So can you please mark my answer and the solution since I gave you specifically what you asked for? Thanks!
Click to expand...

maabadi said:
This is another option:
VBA Code: 
Sub ImportFiles()
Dim wbOpen As Workbook, strPath As String, Lr As Integer, FolderName As String
Dim xStrPath As String, xStrName As String, xStrFName As String, Arr() As String
Dim xWS As Worksheet, xTWB As Workbook, xStrAWBName As String, Z As Integer, i As Integer
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String
On Error Resume Next
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
Set xTWB = ThisWorkbook
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each xWS In xTWB.Worksheets
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = xWS.Name
Next xWS
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
Z = Application.Match(xWS.Name, Arr, False)
Lr = xWS.Range("C" & Rows.Count).End(xlUp).Row
If Z > 0 And Lr > 1 Then
xTWB.Sheets(Z - 1).Range("C10:C" & Lr).Value = xWS.Range("C10:C" & Lr).Value
Z = 0
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Click to expand...
Hi, you replied to my need for help quickly. Thank you. The below macro works perfectly. Thank you! My range column changed from C to Z. When I tried to update the macro, it did not copy each worksheet. Also, now that I recopied your macro into VBA and change the range from C to Z, it causes Excel to crash. Any ideas?
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Multiple Workbooks to one.
2
Replies
11
Views
554
dmt32
D
M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
238
MountainFog
M
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
153
harmless92
H
G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
363
glynn1969
G
GMC The Macro Man
  • Solved
VBA Script - Return to named file
Replies
6
Views
124
mumps
mumps

Forum statistics

Threads
1,214,971
Messages
6,122,525
Members
449,088
Latest member
RandomExceller01

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