Row Duplication based on Cell <>"" in Clumn +1 = TRUE

Attached picture much better description than I can write. Looking to get data into a pivot friendly format via a vba loop. I don't have much experience with writing loops. Many thanks in advance!

2018-01-22 09_08_45-Example.xlsx - Saved.png

Try this for Results starting "A2".

Sub MG22Jan29
Dim Rng As Range, Dn As Range
Dim AcRng As Range, Num As Long, n As Long, Ac As Long, c As Long, Ray(), aNum As Long
Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
    For Each Dn In Rng
        Num = Range("H" & Dn.Row, Cells(Dn.Row, Columns.Count).End(xlToLeft)).Count
        aNum = aNum + Num
        ReDim Preserve Ray(1 To 8, 1 To aNum)
        For n = 1 To Num
             c = c + 1
            For Ac = 1 To 8
               If Ac = 8 Then
                    Ray(Ac, c) = n
               Else
                    Ray(Ac, c) = Dn(, Ac)
               End If
            Next Ac
        Next n
    Next Dn
Range("A2").Resize(c, 8) = Application.Transpose(Ray)
End Sub

Regards Mick

Other way

Sub test()
Dim col_target As Long, lr As Long, x As Long, i As Long, qtrow As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Range("1:1")
    col_target = .Find("Target").Column
    last_col = .Find("*", searchdirection:=xlPrevious).Column
End With
For x = lr To 2 Step -1
    qtrow = Cells(x, Columns.Count).End(xlToLeft).Value - 1
    If qtrow > 0 Then
        Range("A" & x + 1).Resize(qtrow).EntireRow.Insert
        Range("A" & x).Resize(, col_target).Copy Destination:=Range("A" & x + 1, "A" & x + qtrow)
        For i = 1 To qtrow
            Cells(x + i, col_target) = i + 1
        Next
    End If
Next
Range("A:A").Offset(, col_target).Resize(, last_col).ClearContents
End Sub

Kind regards
Leo

Sorry about bringing this back, I thought I had it , but i'm getting a type mismatch error highlighting

qtrow = Cells(x, Columns.Count).End(xlToLeft).Value - 1

when trying to run Leo's code. I'm sure it's my bad...the values in the target columns are text fields

I am sorri to distrub how if i want save this treats to my favorit or to my list thank

AWESOME thank you both a TON!

Looks like both are set up for integers. MickG, I would love to understand how Ray works. Looks awesome. and I can't find any definitions for it online

Sub test()
Dim arr(), i&, ii&, c&, n, t&, j&, a
With [a2].CurrentRegion: a = .Value
For i = 1 To UBound(a, 1)
     n = .Rows(i).Columns.End(xlToRight): t = t + n
     ReDim Preserve arr(1 To 8, 1 To t)
     For j = 1 To n: rw = rw + 1
         For ii = 1 To 8
            If ii = 8 Then
                 arr(ii, rw) = j
            Else
                 arr(ii, rw) = a(i, ii)
            End If
         Next ii
     Next j
Next i
End With
[a2].Resize(t, 8).Value = Application.Transpose(arr)
End Sub]

Originally Posted by daboho

Sub test()
Dim arr(), i&, ii&, c&, n, t&, j&, a
With [a2].CurrentRegion: a = .Value
For i = 1 To UBound(a, 1)
     n = .Rows(i).Columns.End(xlToRight): t = t + n
     ReDim Preserve arr(1 To 8, 1 To t)
     For j = 1 To n: rw = rw + 1
         For ii = 1 To 8
            If ii = 8 Then
                 arr(ii, rw) = j
            Else
                 arr(ii, rw) = a(i, ii)
            End If
         Next ii
     Next j
Next i
End With
[a2].Resize(t, 8).Value = Application.Transpose(arr)
End Sub]

Still getting a type mismatch

without file we only can guess

Kind regards
Leo

Originally Posted by LeoTaxi

without file we only can guess

Kind regards
Leo

Sorry about that. The attachment is exactly the data types and structure of the real. Stuff without headers extends out anywhere from a single column to column cc and rows continue down for several thousand.

Thanks so much in advance, sorry about bad presentation of the situation.

Try

Sub test()
Dim col_t As Long, lr As Long, lr2 As Long, x As Long, i As Long, ii As Long, j As Long
Dim arr() As Variant, arr2() As Variant
With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    With .Range("1:1")
        col_t = .Find("Target").Column - 1
    End With
    .Range("A1").Resize(, col_t + 1).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
    For x = 2 To lr
        With .Rows(x)
            l_col = .Find("*", searchdirection:=xlPrevious).Column
            ec = l_col - col_t
        End With
        ReDim arr(1 To ec, 1 To col_t)
        For i = 1 To ec
            For j = 1 To col_t
                arr(i, j) = Cells(x, j)
            Next
        Next
        ReDim arr2(1 To ec, 1 To 1)
        For i = col_t + 1 To l_col
            ii = ii + 1
            arr2(ii, 1) = Cells(x, i)
        Next
        lr2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & lr2).Resize(UBound(arr), UBound(arr, 2)) = arr
        .Range("A" & lr2).Offset(, col_t).Resize(ec) = arr2
        ii = 0
    Next
    .Range("A2", "A" & lr).EntireRow.Delete
    .Range("A1").EntireRow.Delete
End With
End Sub

Kind regards
Leo

That worked great! Thank you. Only thing that i needed to do was separate all rows that only have one target (again my bad, bad example file) and then it worked like a charm!