excelvbaloops

VBA code for pulling in data for a list of headers from other sheet. And compiling a dataset by repeating the same for all sheets within a workbook

I have a workbook with over 90 sheets. Each sheet contains data for respective request Number (customer). Each sheet contains a row 1= key (Profile Section &"_"& Header), row 2= Profile section, Row 3= Header within each section, and then data rows for request number (1 or more rows). We need to compile the data for specified headers from all the tabs and compile together in a dataset.

  1. I have a list of headers in the dashboard sheet (Table name "Parameters"). This is copied to as column headers for tab "Customer Dataset".

  2. Currently, i have written the code for deleting the old sheet "Customer Dataset" and creating new sheet, with updated list of required headers (flexibility of updating headers) .

  3. Look for the header key in row 3 of "Customer Dataset" and match it with row 1 of first customer sheet, and pull the column values in tab "Customer dataset". Look for other header and repeat the same. So we will have customer data rows for the 1 customer for all specified headers.

  4. Now, this exercise needs to be repeated across all other customer tabs and the data needs to be appended in the sheet "Customer Dataset"

    Any other suggested approach is also highly appreciated. For testing purpose I am currently running the code only across 3 sheets. enter image description here
    enter image description here enter image description here

Pulling selected parameters data in one worksheet

Sub PullData()
Dim wbcompile As Workbook
Dim wssrc, wsdest As Worksheet
Dim ws_Count As Integer
Dim Par_Count As Integer
Dim Par As ListObject

    Application.DisplayAlerts = False
    Set wbcompile = ActiveWorkbook
    wbcompile.Worksheets("Customer Dataset").Delete
    Application.DisplayAlerts = False
    Sheets.Add After:=wbcompile.Worksheets("Dashboard")
    ActiveSheet.Name = "Customer Dataset"
    Set wsdest = ActiveWorkbook.Sheets("Customer Dataset")
    Sheets("Dashboard").Select
    Set Par = Worksheets("Dashboard").ListObjects("Parameters")
    Par_Count = Par.ListColumns(2).Range.Count
    Application.Goto Reference:="Parameters"
    Selection.Copy
    Sheets("Customer Dataset").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Debug.Print Par_Count
    ws_Count = ActiveWorkbook.Worksheets.Count - 2
    Debug.Print ws_Count

End Sub
Solution

  • Something like this (compiled but not tested):

    Sub PullData()
    Dim wbcompile As Workbook
    Dim wsSrc As Worksheet, wsDest As Worksheet, wsPar As Worksheet '<< every variable needs a type
    Dim loPar As ListObject, arr

    Set wbcompile = ActiveWorkbook
    Set wsPar = wbcompile.Worksheets("Dashboard")
    Set loPar = wsPar.ListObjects("Parameters")
    arr = loPar.DataBodyRange.Value 'get parameters as array
    
    Set wsDest = wbcompile.Worksheets("Customer Dataset")
    wsDest.Cells.Clear
    'flip the array and place on summary sheet
    wsDest.Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
    
    For Each wsSrc In wbcompile.Worksheets
        'extract from this sheet?
        If wsSrc.Name <> wsDest.Name And wsSrc.Name <> wsPar.Name Then
            ExtractData wsSrc, wsDest
        End If
    Next wsSrc
End Sub

Sub ExtractData(wsSrc As Worksheet, wsDest As Worksheet)
    Dim lrSrc As Long, nextRowDest As Long, c As Range, m
    
    lrSrc = LastOccupiedRow(wsSrc)  'last row of data on source sheet
    If lrSrc = 3 Then Exit Sub      'no data
    nextRowDest = LastOccupiedRow(wsDest) + 1 'next row to paste to on summary sheet
    'loop over headers in row1 of source sheet
    For Each c In wsSrc.Range("A1", wsSrc.Cells(1, Columns.Count).End(xlToLeft)).Cells
        m = Application.Match(c.Value, wsDest.Rows(3), 0) 'match on summary sheet row 3?
        If Not IsError(m) Then 'got a match?
            'copy row 4 to last row to the summary sheet
            wsSrc.Range(wsSrc.Cells(4, c.Column), wsSrc.Cells(lrSrc, c.Column)).Copy _
                   wsDest.Cells(nextRowDest, m)
        End If
    Next c
End Sub

Function LastOccupiedRow(ws As Worksheet) As Long
    Dim f As Range
    Set f = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not f Is Nothing Then LastOccupiedRow = f.Row
End Function