Excel Vertical to Horizontal Groups VBA based on Active Cell & Specific Column

Original Question Here

I have a VBA script to convert an entire table of mine to a Horizontal table (link above). This is great for specific instances. I'm now hoping someone can help me modify the script to pertain to a smaller subset of the original table.

Here is the main VBA script that converts my entire table to a Horizontal Table on a new sheet:

Sub Demo3()
Dim rngData As Range
Dim i As Long, iR As Long, sKey As String
Dim arrData, ColCnt As Long, RowCnt As Long, aRes()
Dim Sht As Worksheet: Set Sht = Sheets("Master")
Const HEADER_CNT = 2 ' Modify as needed
With Sht.Range("A1").CurrentRegion
    Set rngData = .Offset(HEADER_CNT).Resize(.Rows.Count - HEADER_CNT)
End With
' Sort table w/o header rows
rngData.Sort Key1:=rngData.Cells(3), Header:=xlNo
' load table into an array
arrData = rngData.Value
ColCnt = rngData.Columns.Count
RowCnt = rngData.Rows.Count
ReDim aRes(1 To RowCnt, 2)
For i = LBound(arrData) To UBound(arrData)
    sKey = arrData(i, 1)
    If iR = 0 Then
        iR = 1
        aRes(iR, 0) = sKey: aRes(iR, 1) = i: aRes(iR, 2) = i
    ElseIf aRes(iR, 0) <> sKey Then
        iR = iR + 1
        aRes(iR, 0) = sKey
    End If
    If IsEmpty(aRes(iR, 1)) Then
        aRes(iR, 1) = i
    End If
    aRes(iR, 2) = i
Next i
Dim r As Range, c As Range
' add a sheet for output
Dim ShtNew As Worksheet
Set ShtNew = Sheets.Add(After:=Sheets(Sheets.Count))
Set c = ShtNew.Range("a1")
For i = 1 To iR
    With Range(Sht.Cells(aRes(i, 1) + HEADER_CNT, 1), Sht.Cells(aRes(i, 2) + HEADER_CNT, ColCnt))
        ' write output to sheet
        c.Resize(.Rows.Count, ColCnt).Value = .Value
    End With
    Set c = c.Offset(, ColCnt + 1)
    If c.Column + ColCnt > Sht.Columns.Count Then ' out of space warning
        MsgBox "There is no more space for output."
        Exit For
    End If
Next
End Sub

Here is an example of my main Vertical Table that the code above is converting:

It has 2 Headers
34 Columns (A - AH)
7500+ rows
Column C is a "Library" Column

HEADER1	HEADER1	HEADER1	HEADER1
HEADER2	HEADER2	HEADER2	HEADER2
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 1	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 2	DATA	LIBRARY 1	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA
GROUP 3	DATA	LIBRARY 2	DATA

I need to set the conversion range to all Groups with the same LIBRARY name (Column C), based on the Active Cell - I have code to select this range below.

Sub SelectCurrentLibrary()
Dim searchValue As String
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim rngToSelect As Range

Set ws = ActiveSheet
searchValue = Cells(ActiveCell.Row, 3).Value

' Find the last row in column A
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

' Loop through column A to find matching rows
For Each cell In ws.Range("C3:C" & lastRow)
    If cell.Value = searchValue Then
        If rngToSelect Is Nothing Then
            Set rngToSelect = ws.Range("A" & cell.Row & ":AH" & cell.Row)
        Else
            Set rngToSelect = Union(rngToSelect, ws.Range("A" & cell.Row & ":AH" & cell.Row))
        End If
    End If
Next cell

' Select the final range
If Not rngToSelect Is Nothing Then
    rngToSelect.Select
Else
    MsgBox "No matching rows found."
End If
End Sub

I need to modify the conversion code at the top that converts the table to a horizontal table, to use the "Library Range".

I have tried adding the Library Range code into the Main conversion code but I'm not getting the results I would expect. I though it was due to the inclusion of the Headers in the Main code but even without the headers I still can't get it working.

Solution

Add If clause to filter rows.

Sub Demo4()
    Dim rngData As Range
    Dim i As Long, iR As Long, sKey As String
    Dim arrData, ColCnt As Long, RowCnt As Long, aRes()
    Dim Sht As Worksheet: Set Sht = Sheets("Master")
    Const HEADER_CNT = 2 ' Modify as needed
    Dim searchValue As String
    searchValue = Sht.Cells(ActiveCell.Row, 3).Value
    If Len(searchValue) = 0 Then
        MsgBox "Searching value is blank."
        Exit Sub
    End If
    With Sht.Range("A1").CurrentRegion
        Set rngData = .Offset(HEADER_CNT).Resize(.Rows.Count - HEADER_CNT)
    End With
    ' Sort table w/o header rows
    rngData.Sort Key1:=rngData.Cells(3), Key2:=rngData.Cells(1), Header:=xlNo
    ' load table into an array
    arrData = rngData.Value
    ColCnt = rngData.Columns.Count
    RowCnt = rngData.Rows.Count
    ReDim aRes(1 To RowCnt, 2)
    For i = LBound(arrData) To UBound(arrData)
        If arrData(i, 3) = searchValue Then
            sKey = arrData(i, 1)
            If iR = 0 Then
                iR = 1
                aRes(iR, 0) = sKey: aRes(iR, 1) = i: aRes(iR, 2) = i
            ElseIf aRes(iR, 0) <> sKey Then
                iR = iR + 1
                aRes(iR, 0) = sKey
            End If
            If IsEmpty(aRes(iR, 1)) Then
                aRes(iR, 1) = i
            End If
            aRes(iR, 2) = i
        End If
    Next i
    If iR = 0 Then
        MsgBox "No matching rows found."
    Else
        Dim r As Range, c As Range
        ' add a sheet for output
        Dim ShtNew As Worksheet
        Set ShtNew = Sheets.Add(After:=Sheets(Sheets.Count))
        Set c = ShtNew.Range("a1")
        For i = 1 To iR
            With Range(Sht.Cells(aRes(i, 1) + HEADER_CNT, 1), Sht.Cells(aRes(i, 2) + HEADER_CNT, ColCnt))
                ' write output to sheet
                c.Resize(.Rows.Count, ColCnt).Value = .Value
            End With
            Set c = c.Offset(, ColCnt + 1)
            If c.Column + ColCnt > Sht.Columns.Count Then ' out of space warning
                MsgBox "There is no more space for output."
                Exit For
            End If
        Next
    End If
End Sub