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.

Date	Store	Name	Type	IT	Staffing	Freight	Construction
1/1/2019	123	Joe	New	Comp Issue		Missing Freight
2/1/2019	234	Mike	Reopen	Comp Issue	Short Staff
3/1/2019	345	John	New		Short Staff		Delay Construction
4/1/2019	456	Mary	Expansion			Missing Freight	Delay Construction

<colgroup><col span="3"><col><col><col><col><col></colgroup><tbody>
</tbody>

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

Date	Store	Name	Type	Issue	Details
1/1/2019	123	Joe	New	IT	Comp Issue
1/1/2019	123	Joe	New	Freight	Missing Freight
2/1/2019	234	Mike	Reopen	IT	Comp Issue
2/1/2019	234	Mike	Reopen	Staffing	Short Staff
3/1/2019	345	John	New	Staffing	Short Staff
3/1/2019	345	John	New	Construction	Delay Construction
4/1/2019	456	Mary	Expansion	Freight	Missing Freight
4/1/2019	456	Mary	Expansion	Construction	Delay Construction

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

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