VBA help importing survey data into Master file

M

mfthomps41

New Member
Joined
Jun 22, 2010
Messages
17
Hi. I am wondering if anyone can help me with a macro to import data from multiple (around 500) files that all reside in the same folder, into a single master file.

I would want the following to take place.
1. open first data file (A.xlsx) and copy the survey data (A2:D20).
2. paste the copied data into the Master file (Master.xlsx).
3. close the data file.
4. repeat, opening the remaining files and pasting the corresponding data into the next open rows.

One thing to mention is that each file may have a different number of records, so file A may have 10 lines (A2:D12), and file B may have only 5 (A2:D7).

I am sure this is a pretty simple macro, but I am new to VBA and am lost. Any help is much appreciated. Thanks!
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes
Where are you putting the data? Is it okay if there are empty cells in a, b, c, or d?
 
Last edited:
Upvote 0
Yes, empty cells are ok. For example, assume the columns were as follows; Company | Name | Phone | Email.

Some people may have responded without a phone or email, so there may be a record with only Company and Name, or the like.

Again, all would be in the the same worksheet in their respective file, and I would be looking to import all of them into the Master file, which would have all 4 columns, Company/Name/Phone/Email.

There may be 3 records from the first file, and 7 records from the 2nd file, so after that import, there should be a total of 10 records.
 
Upvote 0
Make sure Master.xlsx IS NOT IN THE SAME FOLDER!!!!!!

I would highly suggest copying the entire folder just in case!!!!!!!

Code: 
Sub Move_TO_MASTER()
    Dim wb As Workbook
    Dim TheFile As String
    Dim MyPath As String
    MyPath = GetFolder
    ChDrive Left(MyPath, Application.WorksheetFunction.Search(":", MyPath))
    ChDir MyPath
    TheFile = Dir("*.xls")
    On Error Resume Next
    Do While TheFile <> ""
        application.screenupdating = false
        Set wb = Workbooks.Open(MyPath & "\" & TheFile)
        GreatestRow = Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(Rows.Count, 2).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 2).End(xlUp).Row
        End If
        If Cells(Rows.Count, 3).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 3).End(xlUp).Row
        End If
        If Cells(Rows.Count, 4).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 4).End(xlUp).Row
        End If
        Windows(TheFile).Activate
        Range("a2:D" & GreatestRow).Copy
        Windows("Master.xlsx").Activate
        LR = Cells(Rows.Count, 1).End(xlUp).Row
        Range("a" & LR).Activate
        ActiveSheet.Paste
      wb.Close
      application.screenupdating = true
      TheFile = Dir
    Loop
End Sub
Function GetFolder(Optional strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Last edited:
Upvote 0
Thanks, this is a great!

One problem though, when I run the macro, it deletes the information after it pastes it, so upon completion I only end up with the information from the last file imported.

Let me know how I can correct this. Thanks again for your help.
 
Upvote 0
I had to redo something anyway

Code: 
Sub Move_TO_MASTER()
    Dim wb As Workbook
    Dim TheFile As String
    Dim MyPath As String
    MyPath = GetFolder
    ChDrive Left(MyPath, Application.WorksheetFunction.Search(":", MyPath))
    ChDir MyPath
    TheFile = Dir("*.xls")
    On Error Resume Next
    Do While TheFile <> ""
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(MyPath & "\" & TheFile)
        GreatestRow = Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(Rows.Count, 2).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 2).End(xlUp).Row
        End If
        If Cells(Rows.Count, 3).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 3).End(xlUp).Row
        End If
        If Cells(Rows.Count, 4).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 4).End(xlUp).Row
        End If
        Windows(TheFile).Activate
        Range("a2:D" & GreatestRow).Copy
        Windows("Master.xlsx").Activate
        LR= Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(Rows.Count, 2).End(xlUp).Row > LRThen
            LR= Cells(Rows.Count, 2).End(xlUp).Row
        End If
        If Cells(Rows.Count, 3).End(xlUp).Row > LRThen
            GreatestRow = Cells(Rows.Count, 3).End(xlUp).Row
        End If
        If Cells(Rows.Count, 4).End(xlUp).Row > LRThen
            LR= Cells(Rows.Count, 4).End(xlUp).Row
        End If
        Range("a" & LR).Select
        ActiveSheet.Paste
      wb.Close
      Application.ScreenUpdating = True
      TheFile = Dir
    Loop
End Sub
Function GetFolder(Optional strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Last edited:
Upvote 0
Ok. I think we are almost there. That fixed the paste issue. The only other thing that I found when I went back and was performing a couple of checks, is that I noticed it cuts off the last row in all of the files except the last one.

I think this is because it pastes over the last column with data, because it will take place over the headers, unless I include a dummy row before running the macro. Any idea on how to fix this.

Other than that its working great!
 
Upvote 0
Lol. We'll get it

Code: 
Sub Move_to_master()
    Dim wb As Workbook
    Dim TheFile As String
    Dim MyPath As String
    MyPath = GetFolder
    ChDrive Left(MyPath, Application.WorksheetFunction.Search(":", MyPath))
    ChDir MyPath
    TheFile = Dir("*.xls")
    On Error Resume Next
    Do While TheFile <> ""
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(MyPath & "\" & TheFile)
        GreatestRow = Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(Rows.Count, 2).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 2).End(xlUp).Row
        End If
        If Cells(Rows.Count, 3).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 3).End(xlUp).Row
        End If
        If Cells(Rows.Count, 4).End(xlUp).Row > GreatestRow Then
            GreatestRow = Cells(Rows.Count, 4).End(xlUp).Row
        End If
        Windows(TheFile).Activate
        Range("a2:D" & GreatestRow).Copy
        Windows("Master.xlsx").Activate
        LR = Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(Rows.Count, 2).End(xlUp).Row > LR Then
            LR = Cells(Rows.Count, 2).End(xlUp).Row
        End If
        If Cells(Rows.Count, 3).End(xlUp).Row > LR Then
            GreatestRow = Cells(Rows.Count, 3).End(xlUp).Row
        End If
        If Cells(Rows.Count, 4).End(xlUp).Row > LR Then
            LR = Cells(Rows.Count, 4).End(xlUp).Row
        End If
        Range("a" & LR + 1).Select
        ActiveSheet.Paste
      wb.Close
      Application.ScreenUpdating = True
      TheFile = Dir
    Loop
End Sub
Function GetFolder(Optional strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question
Update links between excel files
Replies
1
Views
427
Muhammad_Usman
Muhammad_Usman
D
  • Question
Copy Files From Folder Not All Characters
Replies
6
Views
341
John_w
J
B
  • Question
VBA to extract data from multiple folders and add to a master workbook plus identifying tags
Replies
2
Views
861
John_w
J
G
  • Question
Master excel that is updated by; and updates other excel files in folder.
Replies
1
Views
387
AFPathfinder
A
H
  • Question
Amend Macro to limit Selection in C:\My Documents to Vat.*.xlsm
Replies
8
Views
273
howard
H

Forum statistics

Threads
1,215,050
Messages
6,122,868
Members
449,097
Latest member
dbomb1414

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