VBA to loop through range, if match: append part of row and specific column header to table in new sheet

Question

I have a sheet with roughly 12000 rows and 200 columns built up in a way that doesn't allow using it as a proper database. The first 8 columns have data I need, the last 180 columns have "address" headers and an "x" for rows where the column applies, "x" can appear in a row between 1 and 46 times.

Source table format:

I want to loop through each row (only for the last 180 columns) and if a cell contains an "x" then copy values and append to a table in a new sheet:

1. the first 8 cells from that row

2. the header of the column marked by the "x", the header becomes cell 9

3. if there is more than 1 "x" in a row, output should have a new line for every "x" with the a copy of the first 8 cells and the corresponding header in cell 9 [edit: added 3. for clarification]

4. if there is no "x" in a row, that row can be ignored. The next available row in the output table should be populated with the data from the next source row that does have an "x". [edit 2: added 4. for clarification]

Result should look something like this:

I'm no VBA expert and most rows just have 1 "x" so I started with using a formula to populate column 9 with the header of the column marked by "x":

=INDEX(R3C13:R3C192, SUMPRODUCT(MAX((RC[-184]:RC[-5]=R2C198)*(COLUMN(RC[-184]:RC[-5]))))-COLUMN(R[-1]C[-184])+1)

This gives me output for every first "x" on a row, but that leaves a couple of thousand rows with between 2 and 46 times "x".

I tried getting started on this with:

Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Sheets("1").Range("K:R")
rw = Cell.Row
 If Cell.Value = "x" Then
  Cell.EntireRow.Copy
   Sheets("2").Range("A" & rw).PasteSpecial xlPasteValues
 End If
Next
End Sub

Obviously this is a pretty rough start and does not give me:

1. just copy the first 8 cells of the row

2. copy the header of the "x" column to cell 9 (for the right row)

3. It also does not append a new line for each "x" at the bottom of my new table.

I found some answers that are somewhat similar, such as: Loop through rows and columns Excel Macro VBA

But have not been able to make this work for my scenario. Any help would be much appreciated, thanks!

Answer 1

Try this code, this sets the first 8 cells to only the rows that contain "x".

Sub appendit()
Dim i, j, lrow, lcol As Long
Dim rCount, cCount As Long
 Dim addressString As String
Dim wb As Workbook
Dim ws As Worksheet
Dim newWs As Worksheet
Dim vMain As Variant




Set wb = ActiveWorkbook 'or whatever your workbook is
Set ws = wb.Sheets(1) 'or whatever your sheet is
wb.Sheets.Add(before:=wb.Sheets(1)).Name = "Output"
Set newWs = wb.Sheets("Output")
rCount = 1
With ws
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Load the data into an array for efficiency
lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
ReDim vMain(1 To lrow, 1 To lcol)
For i = 1 To lrow
    For j = 1 To lcol
        vMain(i, j) = .Cells(i, j)
    Next j
Next i
End With
With newWs
For i = 21 To UBound(vMain, 2) 'starting from the 21st column as the first 20 are not to be included.
    For j = 1 To UBound(vMain, 1)
        If vMain(j, i) = "x" Then
            .Cells(rCount, 1) = vMain(j, 1)
            .Cells(rCount, 2) = vMain(j, 2)
            .Cells(rCount, 3) = vMain(j, 3)
            .Cells(rCount, 4) = vMain(j, 4)
            .Cells(rCount, 5) = vMain(j, 5)
            .Cells(rCount, 6) = vMain(j, 6)
            .Cells(rCount, 7) = vMain(j, 7)
            .Cells(rCount, 8) = vMain(j, 8)
            .Cells(rCount, 9) = vMain(1, i)
            rCount = rCount + 1   
    End If
    Next j
Next i
End With
End Sub