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