CODEWITHSUNDEEP
vbaexcel
KGK
KGK

Reputation: 107

How to duplicate a row based on column or cell value

I am trying to duplicate rows in excel using VBA and merge columns into one.

The VBA code below hide some columns. i need help edit my code to show all columns(copy col A through col Q).

This is how the original data looks like enter image description here

This is how i would like to end up to enter image description here

This is how i get using the code listed below (problem: doesnt show or copy col. B to Col P)

enter image description here

I would like to show all columns between A and Q. the code below hides all columns except the first and merged one(Col A and merged col on col. B).

 Sub SortMacro()
  Dim SourceSheet As Worksheet
  Dim OutSheet As Worksheet

  Set SourceSheet = ActiveSheet
  Set OutSheet = Sheets.Add

 With SourceSheet
   Out_i = 1
    For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 17 To 20 'or For each i in Array(17,18,20)
        OutSheet.Cells(Out_i, 1) = .Cells(r, 1)
        OutSheet.Cells(Out_i, 2) = .Cells(r, i)
        Out_i = Out_i + 1
    Next
  Next
End With
End Sub

Thanks!

Upvotes: 2

Views: 1824

Answers (1)

barrowc
barrowc

Reputation: 10679

This is my interpretation of what you need. I've added a loop to copy columns A:P into each new row

Sub SortMacro()

Dim SourceSheet As Worksheet
Dim OutSheet As Worksheet

Set SourceSheet = ActiveSheet
Set OutSheet = Sheets.Add

With SourceSheet
  Out_i = 1
  For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
    ' Create a new row for each column entry in Q:T
    For i = 17 To 20
      ' Check the cell isn't empty before creating a new row
      If (.Cells(r, i).Value <> "") Then
        ' Copy columns A:P
        For j = 1 To 16
          OutSheet.Cells(Out_i, j) = .Cells(r, j)
        Next j

        ' Copy the current column from Q:T
        OutSheet.Cells(Out_i, 17) = .Cells(r, i)
        Out_i = Out_i + 1
      End If
    Next i
  Next r
End With

End Sub

Upvotes: 1

Related Questions