Macro to extract column data into new rows

[tparmbru22]

I'm looking for help in creating a macro that can extract select column information and create new rows data but still keep the identifying information. Not all columns will have information and I only want to extract those that have data.

Below is an example of the survey data.

[TABLE="width: 640"]
<colgroup><col span="3"><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Date[/TD]
[TD]Store[/TD]
[TD]Name[/TD]
[TD]Type[/TD]
[TD]IT[/TD]
[TD]Staffing[/TD]
[TD]Freight[/TD]
[TD]Construction[/TD]
[/TR]
[TR]
[TD="align: right"]1/1/2019[/TD]
[TD="align: center"]123[/TD]
[TD]Joe[/TD]
[TD]New[/TD]
[TD]Comp Issue[/TD]
[TD] [/TD]
[TD]Missing Freight[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]2/1/2019[/TD]
[TD="align: center"]234[/TD]
[TD]Mike[/TD]
[TD]Reopen[/TD]
[TD]Comp Issue[/TD]
[TD]Short Staff[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]3/1/2019[/TD]
[TD="align: center"]345[/TD]
[TD]John[/TD]
[TD]New[/TD]
[TD] [/TD]
[TD]Short Staff[/TD]
[TD] [/TD]
[TD]Delay Construction[/TD]
[/TR]
[TR]
[TD="align: right"]4/1/2019[/TD]
[TD="align: center"]456[/TD]
[TD]Mary[/TD]
[TD]Expansion[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Missing Freight[/TD]
[TD]Delay Construction[/TD]
[/TR]
</tbody>[/TABLE]

Below is how I'd like the macro output to look.

[TABLE="width: 427"]
<colgroup><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Date[/TD]
[TD]Store[/TD]
[TD]Name[/TD]
[TD]Type[/TD]
[TD]Issue[/TD]
[TD]Details[/TD]
[/TR]
[TR]
[TD="align: right"]1/1/2019[/TD]
[TD="align: center"]123[/TD]
[TD]Joe[/TD]
[TD]New[/TD]
[TD]IT[/TD]
[TD]Comp Issue[/TD]
[/TR]
[TR]
[TD="align: right"]1/1/2019[/TD]
[TD="align: center"]123[/TD]
[TD]Joe[/TD]
[TD]New[/TD]
[TD]Freight[/TD]
[TD]Missing Freight[/TD]
[/TR]
[TR]
[TD="align: right"]2/1/2019[/TD]
[TD="align: center"]234[/TD]
[TD]Mike[/TD]
[TD]Reopen[/TD]
[TD]IT[/TD]
[TD]Comp Issue[/TD]
[/TR]
[TR]
[TD="align: right"]2/1/2019[/TD]
[TD="align: center"]234[/TD]
[TD]Mike[/TD]
[TD]Reopen[/TD]
[TD]Staffing[/TD]
[TD]Short Staff[/TD]
[/TR]
[TR]
[TD="align: right"]3/1/2019[/TD]
[TD="align: center"]345[/TD]
[TD]John[/TD]
[TD]New[/TD]
[TD]Staffing[/TD]
[TD]Short Staff[/TD]
[/TR]
[TR]
[TD="align: right"]3/1/2019[/TD]
[TD="align: center"]345[/TD]
[TD]John[/TD]
[TD]New[/TD]
[TD]Construction[/TD]
[TD]Delay Construction[/TD]
[/TR]
[TR]
[TD="align: right"]4/1/2019[/TD]
[TD="align: center"]456[/TD]
[TD]Mary[/TD]
[TD]Expansion[/TD]
[TD]Freight[/TD]
[TD]Missing Freight[/TD]
[/TR]
[TR]
[TD="align: right"]4/1/2019[/TD]
[TD="align: center"]456[/TD]
[TD]Mary[/TD]
[TD]Expansion[/TD]
[TD]Construction[/TD]
[TD]Delay Construction[/TD]
[/TR]
</tbody>[/TABLE]

Any help is greatly appreciated.

 

[Fluff]

How about

Sub tparmbru22()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, i As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 4), 1 To 6)
   For r = 2 To UBound(Ary)
      For c = 5 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For i = 1 To 4
               Nary(nr, i) = Ary(r, i)
            Next i
            Nary(nr, 5) = Ary(1, c)
            Nary(nr, 6) = Ary(r, c)
         End If
      Next c
   Next r
   Range("M2").Resize(nr, 6).Value = Nary
End Sub

 

[tparmbru22]

This is good but there are a few issues still.

In the example I only listed 4 columns of data issues but the actual survey can have upwards of 31 columns of data issues.

Also the macro kept the formatted data in the same worksheet. Is it possible to move it to a separate worksheet?

How about

Sub tparmbru22()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, i As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 4), 1 To 6)
   For r = 2 To UBound(Ary)
      For c = 5 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For i = 1 To 4
               Nary(nr, i) = Ary(r, i)
            Next i
            Nary(nr, 5) = Ary(1, c)
            Nary(nr, 6) = Ary(r, c)
         End If
      Next c
   Next r
   Range("M2").Resize(nr, 6).Value = Nary
End Sub

 

[Fluff]

This will put the output on another sheet

Sub tparmbru22()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, i As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 4), 1 To 6)
   For r = 2 To UBound(Ary)
      For c = 5 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For i = 1 To 4
               Nary(nr, i) = Ary(r, i)
            Next i
            Nary(nr, 5) = Ary(1, c)
            Nary(nr, 6) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("A2").Resize(nr, 6).Value = Nary
End Sub

change value in red to suit.
As long as you have a header in row1 for every column, the code should cater for however many columns there are.

 

[tparmbru22]

Thanks that worked perfectly!

This will put the output on another sheet

Sub tparmbru22()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, i As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 4), 1 To 6)
   For r = 2 To UBound(Ary)
      For c = 5 To UBound(Ary, 2)
         If Ary(r, c) <> "" Then
            nr = nr + 1
            For i = 1 To 4
               Nary(nr, i) = Ary(r, i)
            Next i
            Nary(nr, 5) = Ary(1, c)
            Nary(nr, 6) = Ary(r, c)
         End If
      Next c
   Next r
   Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("A2").Resize(nr, 6).Value = Nary
End Sub

change value in red to suit.
As long as you have a header in row1 for every column, the code should cater for however many columns there are.

 

[Fluff]

You're welcome & thanks for the feedback