Looping through columns to find search criteria and paste cell values from another sheet beneath the criteria

Question

The workbook contains three sheets:

1. Item-style (contains in colA the item no., colB the style of the item)

2. Style (List of styles we want)

3. Style template (List of items within the styles specified in the cols)

I need a macro that does three things:

1. Copy the list of styles from the Style sheet and paste & transpose in Style template starting from row 2. Row 1 of all columns needs to be left blank.

2. The macro needs to select each style in style template one by one, which is now in different columns. These will be the search criteria.

3. On the basis of style selected in step 2, the macro needs to do a search in item-style sheet and select all the items that have the selected style and paste all these items beneath the corresponding style in style-template sheet. If there are no items corresponding to the selected style, then it should mention "No items" beneath the corresponding style.

Here's a link to the workbook for easy understanding

StyleProject

Though the workbook mentions only three styles the macro should have the capability of working with more than 50 styles.

Here's the code I have:

Sub StyleProject()
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Set ws = Sheets("Item-Style")
Set ws2 = Sheets("Style")
Set ws3 = Sheets("Style Template")

Dim rng As Range, secRng As Range

Dim i, j, k

Sheets("Style Template").Activate
finalcol = Cells(2, 50).End(x1toleft).Column

For i = 2 To finalcol

j = Cells(2, i).Value

lr = ws.Range("A" & Rows.Count).End(xlUp).Row

For k = 2 To lr
    Set rng = ws.Range("B" & i)

    If StrComp(CStr(rng.Text), j, 1) = 0 Then
        ws.Rows(k & ":" & k).Copy
        nxtRow = ws3.Range(i & Rows.Count).End(xlUp).Row + 1
        ws2.Rows(nxtRow & ":" & nxtRow).PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False


         Set rng = Nothing
            End If
        Next k

Next i
Application.ScreenUpdating = True
End Sub

It ends up in error trying to figure out nextrng I believe.

Answer 1

Sub StyleProject()

    Dim wsStyle As Worksheet
    Dim wsData As Worksheet
    Dim wsTemplate As Worksheet
    Dim StyleCell As Range
    Dim rngFound As Range
    Dim arrResults() As Variant
    Dim strFirst As String
    Dim ResultIndex As Long
    Dim StyleIndex As Long

    Set wsStyle = Sheets("Style")
    Set wsData = Sheets("Item Data")
    Set wsTemplate = Sheets("Style Template")

    With wsStyle.Range("A2", wsStyle.Cells(Rows.Count, "A").End(xlUp))
        If .Row < 2 Then Exit Sub   'No data
        ReDim arrResults(1 To 1 + Evaluate("MAX(COUNTIF(" & wsData.Columns("B").Address(External:=True) & "," & .Address(External:=True) & "))"), 1 To .Cells.Count)
        For Each StyleCell In .Cells
            StyleIndex = StyleIndex + 1
            ResultIndex = 1
            arrResults(ResultIndex, StyleIndex) = StyleCell.Text
            Set rngFound = wsData.Columns("B").Find(StyleCell.Text, wsData.Cells(Rows.Count, "B"), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    ResultIndex = ResultIndex + 1
                    arrResults(ResultIndex, StyleIndex) = wsData.Cells(rngFound.Row, "A").Text
                    Set rngFound = wsData.Columns("B").Find(StyleCell.Text, rngFound, xlValues, xlWhole)
                Loop While rngFound.Address <> strFirst
            End If
        Next StyleCell
    End With

    If UBound(arrResults, 1) > 1 Then
        wsTemplate.Range("B2", wsTemplate.Cells(Rows.Count, Columns.Count)).Clear
        wsTemplate.Range("B2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults
        With wsTemplate.Range("B2").Resize(, UBound(arrResults, 2))
            .Font.Bold = True
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .EntireColumn.AutoFit
        End With
    End If

    Set wsStyle = Nothing
    Set wsData = Nothing
    Set wsTemplate = Nothing
    Set StyleCell = Nothing
    Set rngFound = Nothing
    Erase arrResults

End Sub