0

I am trying to produce a report where a column containing multiple unique data are used as identifiers in pulling data from a source table/database where the lookup array contains cells or fields that have multiple, heterogeneous, and repetitive data.

The below illustration can explain what I am trying to accomplish:

This is the source table

Source Table (Input)

And the below report is what I am trying to accomplish:

Report (Output)

I am trying to find similar questions but to no avail. I can classify myself as intermediate user in Excel especially on the VBA side.

3
  • for the output, if you were willing to create the first column yourself i.e input all the unique values, the look up part for the other 2 columns should be fairly simple, let me know and ill put in an answer
    – PeterH
    Oct 17, 2017 at 10:45
  • Hi User91504! Thank you for your response. Yup, I already have the first column updated from time to time. My only concern is to pull the 2nd and 3rd columns out from the source table. Oct 18, 2017 at 0:50
  • Hopefully someone who is kind enough can shed light to this question. Oct 19, 2017 at 3:52

1 Answer 1

1

I had some spare time, so I wrote a VBA Macro that can automate this. Since you have some knowledge of VBA, do go thru this code and understand where ever there exists little bit of hard coding. The macro does three things

  1. Transpose data from the input table into output table.
  2. Sort the Output table
  3. Merge the duplicate value cells in first column. However I suggest that you comment this part of the code, so that in future applying Pivot Table to output table shall be simplified if required.

In this example, Input table is in A1:C4 (A2:A4 being the Product Name cells). The output table starts at cell E1. Put this hard coding in VBA to match your table ranges. The sheet be named as 'Sheet1'. There is hard coding for Sheet name and Input Cell Range and Output Start Cell in the code. Please see all instances for the code to work correctly.

In your sheet press ALT + F11 to open VBA Editor and Insert a Module and paste the below code into it to create a Macro named Report.

Sub Report()
Dim noofrows As Integer
Dim startrow As Integer
Dim startcol As Integer
Dim repstartrow As Integer
Dim repstartcol As Integer
Dim bincode As String
Dim storagecode As String
'Hard Coding below
noofrows = Range("A2:A4").Rows.Count  'Specify the Input Data Range from a Column
startrow = Range("A2").Row
startcol = Range("A2").Column
repstartrow = Range("E1").Row         'Specify Output Data Table's First Cell here
repstartcol = Range("E1").Column

Cells(repstartrow, repstartcol).Value = "Products"
Cells(repstartrow, repstartcol).Font.Bold = True
Cells(repstartrow, repstartcol + 1).Value = "BinCode"
Cells(repstartrow, repstartcol + 1).Font.Bold = True
Cells(repstartrow, repstartcol + 2).Value = "StorageCode"
Cells(repstartrow, repstartcol + 2).Font.Bold = True

repstartrow = repstartrow + 1

For i = 1 To noofrows

   Dim strTest As String
   Dim strArray() As String
   Dim intCount As Integer

   strTest = Cells(startrow, startcol).Value
   strArray = Split(strTest, ";")
   bincode = Cells(startrow, startcol + 1).Value
   storagecode = Cells(startrow, startcol + 2).Value


   For intCount = LBound(strArray) To UBound(strArray)
      Cells(repstartrow, repstartcol).Value = strArray(intCount)
      Cells(repstartrow, repstartcol + 1).Value = bincode
      Cells(repstartrow, repstartcol + 2).Value = storagecode
      repstartrow = repstartrow + 1
   Next intCount
   startrow = startrow + 1

Next i

'Create All Borders to the table
'Hard Coding below
repstartrow1 = Range("E1").Row
repstartcol = Range("E1").Column

repstartrow = repstartrow - 1

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With

'Auto Fit the Columns
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Columns.AutoFit

'Sort the range on Product then Bincode & then StorageCode

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol), Cells(repstartrow, repstartcol)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 1), Cells(repstartrow, repstartcol + 1)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 2), Cells(repstartrow, repstartcol + 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'Optional - Merge Cells with repeating Values. Simply comment below code if not desired
repstartrow1 = Range("E1").Row + 1
repstartcol = Range("E1").Column

Application.DisplayAlerts = False
For i = repstartrow1 To repstartrow - 1
        For j = i + 1 To repstartrow
            If Cells(i, repstartcol).Value <> Cells(j, repstartcol).Value Then
                Exit For
            End If
        Next
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).Merge
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).VerticalAlignment = xlTop
        i = j - 1
    Next
Range(Cells(repstartrow1 - 1, repstartcol), Cells(repstartrow1 - 1, repstartcol)).Select

Application.DisplayAlerts = True

End Sub

Save and exit back to Worksheet. Press ALT + F8 to access Macro Dialog Box and Run the Macro named Report to get the desired output table. Note that you should not re-run this Macro again and again. It will work only once. However you can clear the previous output table and re-run this macro again to recreate the output table from scratch. Macro can be further enhanced to clear previous table as a first step before proceeding.

enter image description here

1
  • Thanks pat2015. That is helpful. I guess everyone is busy. :) Oct 19, 2017 at 9:49

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .