VBA Copy/Paste then Delete Row

[cmschmitz24]

Hello, I need help writing a VBA code that will copy/paste values into a row, then delete the row they were copied from. This is based on if the value in column D is the same. See before and after pictures.

Before:

After:

 

[maras]

Row 1 of the data has headers.

Sub Transposition_maras()
    Dim a(), af
    Dim i As Long, r As Long
    Dim c As Integer
    
    With Sheets("Sheet1").[A1].CurrentRegion
        a = .Value
        ReDim af(1 To UBound(a), 1 To 200)
        For i = 2 To UBound(a)
            If a(i, 4) = a(i - 1, 4) Then
                c = c + 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            Else
                r = r + 1
                c = 15
                af(r, 4) = a(i, 4)
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            End If
        Next
        With .Offset(1, 0)
            .ClearContents
            .Resize(r, UBound(af, 2)) = af
        End With
    End With
End Sub

 

[Fluff]

@maras
If the OP has data in the blank columns (which is more than likely) won't your code delete it all?

 

[cmschmitz24]

Yes there is data in the blank columns and yes the code delete all of that data. Otherwise, the code worked perfectly.

 

[JLGWhiz]

Based on the before and after images, this would produce the results in the "After" image.

Sub t()
Dim i As Long
    With ActiveSheet
        For i = .Cells(Rows.Count, 4).End(xlUp).Row To 2 Step -1
            If .Cells(i, 4).Value = .Cells(i - 1, 4).Value Then
                .Range(.Cells(i, 15), .Cells(i, Columns.Count).End(xlToLeft)). _
                Copy .Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
                .Rows(i).Delete
            End If
        Next
    End With
End Sub

 

[maras]

Corrected code.

Sub Transforming_maras()
    Dim a(), af, rws
    Dim i As Long, r As Long
    Dim c As Integer
    
    With Sheets("Sheet1").[A1].CurrentRegion
        a = .Value
        ReDim af(1 To UBound(a), 1 To 200)
        ReDim rws(1 To UBound(a))
        
        For i = 2 To UBound(a)
            If a(i, 4) = a(i - 1, 4) Then
                c = c + 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            Else
                r = r + 1
                rws(r) = i
                c = 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            End If
        Next
        ReDim Preserve rws(1 To r)
        rws = Application.Transpose(rws)
        With .Offset(1, 0)
            .ClearContents
            .Resize(r, 14) = Application.Index(a, rws, Application.Transpose(Evaluate("Row(1:" & 14 & ")")))
            .Offset(, 14).Resize(r, UBound(af, 2)).Value = af
        End With
    End With
End Sub

 

[cmschmitz24]

Corrected code.

Sub Transforming_maras()
    Dim a(), af, rws
    Dim i As Long, r As Long
    Dim c As Integer
   
    With Sheets("Sheet1").[A1].CurrentRegion
        a = .Value
        ReDim af(1 To UBound(a), 1 To 200)
        ReDim rws(1 To UBound(a))
       
        For i = 2 To UBound(a)
            If a(i, 4) = a(i - 1, 4) Then
                c = c + 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            Else
                r = r + 1
                rws(r) = i
                c = 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            End If
        Next
        ReDim Preserve rws(1 To r)
        rws = Application.Transpose(rws)
        With .Offset(1, 0)
            .ClearContents
            .Resize(r, 14) = Application.Index(a, rws, Application.Transpose(Evaluate("Row(1:" & 14 & ")")))
            .Offset(, 14).Resize(r, UBound(af, 2)).Value = af
        End With
    End With
End Sub

Thank you! This worked perfect.