VBA help importing survey data into Master file

[mfthomps41]

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!

 

[RSXchin]

Where are you putting the data? Is it okay if there are empty cells in a, b, c, or d?

 

[mfthomps41]

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.

 

[RSXchin]

Make sure Master.xlsx IS NOT IN THE SAME FOLDER!!!!!!

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

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

 

[RSXchin]

You've got me sitting on edge wondering if it's working...

 

[mfthomps41]

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.

 

[RSXchin]

I had to redo something anyway

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

 

[RSXchin]

I did change it, so you may have to copy the whole thing again.

 

[mfthomps41]

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!

 

[RSXchin]

Lol. We'll get it

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