Thread: take extra columns of rows and move to new line

Hi,
Thanks for checking out this post. I have a question about some data I need to sort. I imagine an excel macro is going to be the answer, but I don't have any idea how to code what I need. If you might be able to help, please read on!

Basically, I have data arranged in the following way:
DateA NameA Word1a Word2a
DateB NameB Word1b
DateC NameC Word1c Word2c Word3c Word4c
and so forth.

In other words, there are always A, B and C column, but there may also be a D through ?? column. What I need to do is to move any data in the D+ columns to a new row with the information in columns A and B from the row it was originally on duplicated.

So, using the macro would result in something like this:
DateA NameA Word1a
DateA NameA Word2a
DateB NameB Word1b
DateC NameC Word1c
DateC NameC Word2c
DateC NameC Word3c
DateC NameC Word4c
etc.

Thanks in advance for any help!

Nick

You could use this code:

Sub Macro1()
   Dim lastRow As Long, lastCol As Integer
   Dim r As Long, c As Integer
   
   With ThisWorkbook.ActiveSheet
      lastRow = .Cells(Rows.Count, "a").End(xlUp).Row
      For r = lastRow To 2 Step -1
         lastCol = .Cells(r, Columns.Count).End(xlToLeft).Column
         If lastCol > 3 Then
            .Rows(r + 1).Resize(lastCol - 3).Insert Shift:=xlDown
            .Cells(r + 1, 3).Resize(lastCol - 3) = WorksheetFunction.Transpose(.Cells(r, 4).Resize(, lastCol - 3))
            .Cells(r, 4).Resize(, lastCol - 3).ClearContents
            .Cells(r + 1, 1).Resize(lastCol - 3) = .Cells(r, 1)
            .Cells(r + 1, 2).Resize(lastCol - 3) = .Cells(r, 2)
         End If
      Next r
   End With
End Sub

Regards,
Antonio

Wow, this works great. Thanks for the quick reply, too!

Although, I goofed, and there are 3 cells that need to be reproduced when a new row is made, not just 2. I played around with the numbers in the code you posted but only managed to break things or do funky stuff. Could you show whatever changes need to be made to do this? Sorry!

In this macro you can change fixed Columns number:

Sub Macro1()
   Dim lastRow As Long, lastCol As Integer
   Dim r As Long, c As Integer, fixedCols As Integer
   
   fixedCols = 3
   With ThisWorkbook.ActiveSheet
      lastRow = .Cells(Rows.Count, "a").End(xlUp).Row
      For r = lastRow To 2 Step -1
         lastCol = .Cells(r, Columns.Count).End(xlToLeft).Column
         If lastCol > fixedCols + 1 Then
            'insert rows
            .Rows(r + 1).Resize(lastCol - fixedCols - 1).Insert Shift:=xlDown
            .Cells(r + 1, fixedCols + 1).Resize(lastCol - fixedCols - 1) = _
                  WorksheetFunction.Transpose(.Cells(r, fixedCols + 2).Resize(, _
                  lastCol - fixedCols - 1))
            .Cells(r, fixedCols + 2).Resize(, lastCol - fixedCols - 1).ClearContents
            'copy fixed cols down
            For c = 1 To fixedCols
               .Cells(r + 1, c).Resize(lastCol - fixedCols - 1) = .Cells(r, c)
            Next c
         End If
      Next r
   End With
End Sub

Regards,
Antonio

Thanks Antonio. It works perfectly. You rock!