Data consolidation !

[pkumar_pl]

Hi.

I am an University graduate and I recently started leaning VBA. I tried to adapt available code for my purpose. I have seen in the forum that people have been helping a lot so I decised to ask for your help to resolve my problem. I am working on an University project to conduct a survery from google forms. From the survery I am getting several responces in the form of excel which I need to consolidate in a filem lets say a master file. This mater file will be used for data analysis. I tried to adapt a VBA code posted by other user in the forum but I am not able to copy each row in the master sheet properly. Here my objective to just copy the data range from A2 to AH2 to master sheet. I have attached the files so that you guys can have a look.

Regards,

Prashant

Option Explicit

Sub ConsolidateDta()
Dim i As Integer, LR As Integer, LRS As Integer
Dim fil As String
Dim Col As String
Dim cpy As String
Dim ws As Worksheet, wsm As Worksheet
Dim twb As Workbook
Dim c As Range
Dim j As Integer
Dim xlname As String

Set ws = Sheet1 ' List sheet
Set wsm = Sheet2 ' MasterData sheet
Set twb = ThisWorkbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To ws.Range("B65536").End(xlUp).Row 'Sheet1 is MasterSheet
   
    fil = ws.Range("C" & i) & ws.Range("B" & i) 'File Location plus XL name
    xlname = Right(fil, Len(fil) - InStrRev(fil, "\"))
    cpy = ws.Range("D" & i) & ":" & ws.Range("E" & i) 'Copy Range
    Col = Left(ws.Range("B" & i), 1) 'Col to paste to
   
    wsm.Select
    LRS = Range("A" & Rows.Count).End(xlUp).Row
   
    On Error GoTo Err
    Workbooks.Open fil, 0, 1 'Open Read Only
    LR = Range("A" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    For Each c In wsm.Range("A1:AH2")
      Windows(xlname).Activate
      j = Range("A1:AH2").Find(c).Column
      Range(Cells(2, j), Cells(LR, j)).Copy
     
      Windows(twb.Name).Activate
      wsm.Select
      Range(Cells(LRS + 1, c.Column), Cells(LR + LRS + 1, c.Column)).PasteSpecial xlPasteValues
    Next c
    On Error GoTo 0
   
    Windows(xlname).Activate
    ActiveWorkbook.Close False 'Close no save
Next i

Application.DisplayAlerts = False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox "The file " & ws.Range("b" & i) & " is missing. Operation incomplete."
End Sub

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Set headers = Worksheets("Worksheet").Range("A1:Z1")

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet1").Cells(2, GetHeaderColumn(header.Value))
        End If
    Next
End Sub

Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("Sheet1").Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

 

[Chihiro]

So each answer sheet contains only single answer?

If using Google forms to take survey, you can just sync the result from the Google sheet, rather than exporting each response as separate workbook.

To sync Excel with Google sheet, read link below.
https://www.connordphillips.com/2016/01/15/syncing-google-sheets-data-to-excel/

If that's not an option... you can try the link below to merge multiple workbooks that has same structure (you'll need to modify the code a bit, change [Sheet1$] in code with your worksheet).

http://chandoo.org/forum/threads/merge-sheet1-from-multiple-workbook-using-single-connection.33746/

 

[pkumar_pl]

Dear Chihiro, thank you very much for the tip. This solved my most of the problem.