Change Data Layout

[DanniiMarie]

I have a manifest of items shipped to store locations but it needs to be uploaded to a service in a very specific format. I know there is a quick way to complete this task using a macro but just don't know where to start. Here is the format I have:

Store #	Store Name	Item #1	Item #2	Item#3	Item #4
1234	Wowza on Main	1	0	0	4
5678	Wowza on 2nd	5	0	3	0
9012	Wowza on 15th	1	0	0	1
3456	Wowza on 22nd	1	2	1	1

The format I need ignores the zeros and rearranges things like this:

Store Name	Content	Store #
Wowza on Main	Item 1	1234
Wowza on Main	Item 4	1234
Wowza on 2nd	Item 1	5678
Wowza on 2nd	Item 3	5678
Wowza on 15th	Item 1	9012
Wowza on 15th	Item 4	9012
Wowza on 22nd	Item 1	3456
Wowza on 22nd	Item 2	3456
Wowza on 22nd	Item 3	3456
Wowza on 22nd	Item 4	3456

Notice how it doesn't matter what the # is in the item columns so long as it is not a zero. The new table can be on a new tab and the tab title doesn't matter as I can simply cut and paste the results of the macro into my upload sheet.

Can someone help me with this?

 

[Peter_SSs]

Give this a try with a copy of your data.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("A1").CurrentRegion.Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 3)
  For i = 2 To UBound(a)
     For j = 3 To uba2
      If a(i, j) <> 0 Then
        k = k + 1
        b(k, 1) = a(i, 2)
        b(k, 2) = a(1, j)
        b(k, 3) = a(i, 1)
      End If
     Next j
  Next i
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(k, UBound(b, 2)).Value = b
End Sub

 

[DanniiMarie]

Give this a try with a copy of your data.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
 
  a = Range("A1").CurrentRegion.Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 3)
  For i = 2 To UBound(a)
     For j = 3 To uba2
      If a(i, j) <> 0 Then
        k = k + 1
        b(k, 1) = a(i, 2)
        b(k, 2) = a(1, j)
        b(k, 3) = a(i, 1)
      End If
     Next j
  Next i
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(k, UBound(b, 2)).Value = b
End Sub

That was the help I needed! THANK YOU! You saved a lot of people A LOT of unnecessary keying!

 

[Peter_SSs]

That was the help I needed! THANK YOU! You saved a lot of people A LOT of unnecessary keying!

You're welcome. Thanks for the follow-up.

 

[DanniiMarie]

You're welcome. Thanks for the follow-up.

Used the macro on a live job today and it worked beautifully. Thank you again!

 

[Peter_SSs]

Used the macro on a live job today and it worked beautifully.