Collating Survey data

[GrahamH]

Hi

I am looking for a way to automate gathering survey data collected on excel worksheets onto a master database.

I need to copy from the range $A$2:$C11 on a Worksheet named "Survey" from up to 400 workbooks into one worksheet, along with the Workbook name column $A and the data into the columns $B:$D. All workbooks will be located in the one directory.

The data from the next worksheet is to be placed directly below the last data pasted.

There will also be a hidden worksheet "Lookup".

The data should look as follows:

FileName Report Ad hoc Frequency
CC2200 ERA No Never
CC2200 GR Yes Never
CC2200 HL Yes Monthly
CC2200 IES No Annually
CC2200 MCI Yes Annually
CC2200 NCI Yes Annually
CC2200 OLS Yes Annually
CC2200 RAS Yes Weekly
CC2200 RTC No Weekly
CC2200 VAR No Annually

Information in Column A should be the file name and the data placed in Columns B:D

There is no issue about the sequence of the data.

I would greatly appreciate any assistance.

Thanks in advance

 

[agihcam]

Hi -
Try this code ( Untested ) but hopefully will work. Workbooks in c:\temp folder. paste this code into new workbook.

Sub gathersurvey()
ActiveWorkbook.Sheets(1).Cells.Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False

    'dimension variables
    Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
    Dim ws1 As Worksheet, Ws2 As Worksheet, i, ii As Long, Pos As Long
    Dim Folder As String, File As String, Path As String
    'folder to loop through
    Folder = "C:\temp" 'change to suit
    'set destination info
    Set wsDest1 = ActiveWorkbook.Sheets(1) '<<== is this correct?
    'Start FileSearch
    With Application.FileSearch
        .LookIn = Folder
        .Filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks
        .SearchSubFolders = False
        .Execute
        If .Execute > 0 Then
            'loop through all found files
            For i = 1 To .FoundFiles.Count
                'set incidental variables
                Pos = InStrRev(.FoundFiles(i), "\")
                File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
                Path = Left(.FoundFiles(i), Pos)
                'check if workbook is open.  if so, set variable to it, else open it
                If IsWbOpen(File) Then
                    Set wb = Workbooks(File)
                Else
                    Set wb = Workbooks.Open(Path & File)
                End If
                'set worksheets to copy data from
                Set ws1 = wb.Sheets("Survey")
                'copy data
                ws1.Range("a2:c11").Copy
                With wsDest1.Cells(Rows.Count, 2).End(xlUp).Offset(1)
                .PasteSpecial xlValues
                End With
                For ii = 2 To wsDest1.Range("b" & Rows.Count).End(xlUp).Row
                If wsDest1.Cells(ii, 1) = "" Then
                wsDest1.Cells(ii, 1).End(xlUp).Offset(1) = Left(File, Len(File) - 4)
                End If
                Next
                 wb.Close
            Next i
        End If
    End With
    
    Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
    Set Ws2 = Nothing: Set wb = Nothing

Application.ScreenUpdating = true
Application.DisplayAlerts = true
End Sub
Function IsWbOpen(wbName As String) As Boolean
    On Error Resume Next
    IsWbOpen = Len(Workbooks(wbName).Name)
End Function

 

[GrahamH]

agihcam

Thanks for that

I have modified your code to suit my specific needs and it seems to work a treat on a small sample of data.

Thanks very much your help is much appreciated