VBA looping IF to transform a multi item row into a flat file

[George_Martin_3]

Name|Address|Item1|qty|item2|qty|
:--|:--|:--|:--|:--|:--|
Dan|456 Cold|Apple|2|Donkey|4|
Steve|123 Ripple|Dove|3|||
Nate|985 Tara|Monkey|1|Fish|2|


Hi all,
With my sample data above (imagine there's actually more columns like contact phone, state, zip, email yada yada yada) I need a procedure to copy/destination a unique row each item. A looping if to create a flat file so it looks like this below.
Any hints appreciated.

Name|Address|Item|Qty|
:--|:--|:--|:--|
Dan|456 Cold|Apple|2|
Dan|456 Cold|Donkey|4|
Steve|123 Ripple|Dove|3|
Nate|985 Tara|Monkey|1|
Nate|985 Tara|Fish|2|
||||

 

[Rijnsent]

Hi George,
if you want to do it without VBA/macros, you can achieve this by mainly the OFFSET formula. I copy-pasted your data on a sheet named DATA and put these formula on the next sheet (starting in A1):

ROW|ITEM|Name|Address|Item|qty
2|1|=OFFSET(DATA!$A$1,A2,0)|=OFFSET(DATA!$B$1,A2,0)|=OFFSET(DATA!$C$1,A2,(B2-1)*2)|=OFFSET(DATA!$D$1,A2,(B2-1)*2)
=IF(B3>B2,A2,A2+1)|=IF(OFFSET(DATA!$A$1,A2,2+2*B2)>0,B2+1,1)|=OFFSET(DATA!$A$1,A3,0)|=OFFSET(DATA!$B$1,A3,0)|=OFFSET(DATA!$C$1,A3,(B3-1)*2)|=OFFSET(DATA!$D$1,A3,(B3-1)*2)

And drag those formulas down.
Hope that helps,
Koen

 

[Peter_SSs]

imagine there's actually more columns ..

It isn't clear to me whether those extra columns are part of the columns that repeat for every row (like "Dan", "456 Cold") or whether you mean more sets of columns of "Item" & "qty". So, if you cannot adapt this, which is written for your sample data layout, post back with more details.

Sub Rearrange()  Dim a As Variant, b As Variant
  Dim uba2 As Long, i As Long, j As Long, k As Long
  
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2) / 2, 1 To 4)
  For i = 1 To UBound(a)
    For j = 3 To uba2 Step 2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, j): b(k, 4) = a(i, j + 1)
      End If
    Next j
  Next i
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(k, UBound(b, 2)).Value = b
End Sub

My sample data (rows 1:4) and code results (rows 7:11)

Book1
	A	B	C	D	E	F
1	Name	Address	Item1	qty	item2	qty
2	Dan	456 Cold	Apple	2	Donkey	4
3	Steve	123 Ripple	Dove	3
4	Nate	985 Tara	Monkey	1	Fish	2
5
6
7	Dan	456 Cold	Apple	2
8	Dan	456 Cold	Donkey	4
9	Steve	123 Ripple	Dove	3
10	Nate	985 Tara	Monkey	1
11	Nate	985 Tara	Fish	2
Sheet1