Thread: Condense duplicate data to one row, data in same column in new row

Hi

See how this goes.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  OutSH.Cells.ClearContents
  
  Sheets("Sheet1").Activate
  
  For Each ce In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If WorksheetFunction.CountIf(OutSH.Range("A:A"), ce.Value) = 0 Then
      If IsEmpty(OutSH.Cells(1, 1)) Then
        outrow = 1
      Else
        outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Row + 1
      End If
      OutSH.Cells(outrow, 1).Value = ce.Value
    End If
    Set findit = OutSH.Range("A:A").Find(what:=ce.Value)
    For i = 2 To Cells(ce.Row, Columns.Count).End(xlToLeft).Column
      If Not IsEmpty(Cells(ce.Row, i)) Then
        OutSH.Cells(findit.Row, i).Value = Cells(ce.Row, i).Value
      End If
    Next i
    
  Next ce
  
End Sub

rylo

Thank you! That does exactly what I wanted.

Chris

Thanks, Rylo.

Something has changed - what if I want to perform the function on the same spreadsheet instead of copying the cells to a 2nd spreadsheet?

Chris

Hi

One way would be to create a temporary spreadsheet, use the above macro to put it to that temporary sheet, copy from the temp over the original, then remove the temporary sheet.

Would that suffice?

rylo

Yes, that would be okay.
I would need the copied cells to be put onto an existing sheet (Sheet2) that has labeling across the first 3 rows.
So is there a way to specify that the data be copied starting at row 4?

Thanks again.

Chris

Chris

Put up an updated example file showing your real stucture, how it starts, and how it is to look when completed.

ryl

Hi,
Here is an example of the spreadsheet.

The data is Parts (with some items such as description, cost, etc.) and Due Dates with quantity and weekday.

Sheet "Input" has the data (brought in from an ODBC link to a database) and the various dates (with quantity and weekday) spread out across the columns based on week number.
At this point, the spreadsheet is usable except that a single part appears on more than one row if it has more than one due date. So the only change that would need to occur is the condensing of the mentioned rows to a single row. The dates are already in the correct column, they just need to move to the first row that its related part number appears and the remaining duplicate rows of that part number deleted (after all the dates are moved to the same row).

Sheet "Output" shows how the data should be condensed to a single row per part with the various due dates spread across the columns on the same row (note, the dates did not have to move columns, they just had to move to the first row that the part appeared).

Rows 1-3 contain static labels. Columns 1-7 contain part number, description items such as order, customer part number, etc. These columns/rows will always contain this info. It may not always contain the same part numbers, it changes based on orders/production.

The due dates start at column 8-63. These columns will always contain this info.

Thank you and do let me know if you need any other info or clarification.

Chris

Chris

See how this goes for the example file.

Sub DataConsol()
  Dim OutSH As Worksheet, rng As Range
  Set OutSH = Sheets("OUTPUT")
  With OutSH
    lastrow = WorksheetFunction.Max(4, .Cells(Rows.Count, 1).End(xlUp).Row)
    .Rows("4:" & lastrow).ClearContents
  End With
  Sheets("INPUT").Select
  For Each ce In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    lastrow = WorksheetFunction.Max(5, OutSH.Cells(Rows.Count, 1).End(xlUp).Row)
    Set rng = OutSH.Range("A4:A" & lastrow)
    cnta = Evaluate("=sumproduct(--(output!" & rng.Address & "= " & ce.Address & "),--(output!" & rng.Offset(0, 1).Address & "=" & ce.Offset(0, 1).Address & "),--(output!" & rng.Offset(0, 2).Address & "=" & ce.Offset(0, 2).Address & "),--(output!" & rng.Offset(0, 3).Address & "=" & ce.Offset(0, 3).Address & "),row(output!" & rng.Address & "))")
    If cnta = 0 Then
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      OutSH.Cells(outrow, 1).Value = ce.Value
      OutSH.Cells(outrow, 2).Value = ce.Offset(0, 1).Value
      OutSH.Cells(outrow, 3).Value = ce.Offset(0, 2).Value
      OutSH.Cells(outrow, 4).Value = ce.Offset(0, 3).Value
      OutSH.Cells(outrow, 5).Value = ce.Offset(0, 4).Value
    Else
      outrow = cnta
    End If
    
    For i = 6 To Cells(ce.Row, Columns.Count).End(xlToLeft).Column
      If Len(Cells(ce.Row, i)) > 0 Then
        OutSH.Cells(outrow, i).Value = Cells(ce.Row, i).Value
      End If
    Next i
    
  Next ce
  
  MsgBox "Completed"

End Sub

rylo