Question

Creating macros in Excel is not my strong point so I’m wondering if someone is able to help.

I have a small table with product values, though not every cell has a value. What I’m trying to do is write a macro to create a list on a separate sheet. The macro I have written works for the first column but that’s where it stops.

For example

List | aa | bb   | cc

a    |1   | 15   |  -

b    |2   | 23   | 12

c    |-   | 17   | 5

d    |4   | -    | -

Should appear on Sheet 2 like so

- List| aa
- a   | 1
- b   | 2
- d   | 4
- List| bb
- a   | 15
- b   | 23
- c   | 17
- List| cc
- b   | 12
- c   | 5

At the moment, only aa shows correctly on the 2nd sheet and none of the other columns.

The macro I have so far is

Sub Button2_Click()
    Dim Column As Integer
    Column = 1
    newrow = 1
    Do Until Worksheets("Sheet1").Cells(Column, 1).Value = ""

        If Worksheets("Sheet1").Cells(Column, 2).Value <> "" Then

            Worksheets("Sheet2").Cells(newrow, 1).Value = Worksheets("Sheet1").Cells(Column, 1).Value
            Worksheets("Sheet2").Cells(newrow, 2).Value = Worksheets("Sheet1").Cells(Column, 2).Value

            newrow = newrow + 1
        End If
        Column = Column + 1
    Loop

End Sub

Answer 1

This is what I was suggesting. This code sample is based on the above sample data. If the structure of the sample changes then you will have to amend the code accordingly. I have commented the code so that you shouldn’t have a problem understanding it. But if you do, simply post back 🙂

CODE

Option Explicit

Sub Sample()
    '~~> Input/Output Sheets
    Dim wsI As Worksheet, wsO As Worksheet
    Dim Lrow As Long, ORow As Long, i As Long
    Dim rngToFilter As Range

    '~~> Set the input, output sheets
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set wsO = ThisWorkbook.Sheets("Sheet2")

    '~~> Set the output row in the new sheet
    ORow = 1

    With wsI
        '~~> Get last row in Col A
        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Set your range
        Set rngToFilter = .Range("A1:D" & Lrow)

        '~~> Hide Col C to E
        .Range("C:E").EntireColumn.Hidden = True

        '~~> Loop through Col B to Col D
        For i = 2 To 4

            '~~> Remove any filters
            .AutoFilterMode = False

            '~~> Copy Header viz List| aa, List| bb
            Union(.Cells(1, 1), .Cells(1, i)).Copy wsO.Range("A" & ORow)

            '~~> Get next empty row
            ORow = ORow + 1

            '~~> Filter, offset(to exclude headers) and copy visible rows
            With rngToFilter
                .AutoFilter Field:=i, Criteria1:="<>"

                '~~> Copy the filtered results to the new sheet
                .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsO.Range("A" & ORow)
            End With

            ORow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1

            '~~> Unhide/Hide relevant columns
            .Columns(i).EntireColumn.Hidden = True
            .Columns(i + 1).EntireColumn.Hidden = False

            '~~> Remove any filters
            .AutoFilterMode = False
        Next i

        '~~> Unhide all columns
        .Range("B:E").EntireColumn.Hidden = False
    End With
End Sub

SCREENSHOT