Macro to Combine Multiple Rows into One Row

macropod · #6 01-12-2015, 10:04 PM

Try the following macro:

Code:

Sub Demo()
Dim lRow As Long, lCol As Long, i As Long, j As Long, SBar As Boolean
With Application
  SBar = .DisplayStatusBar
  .DisplayStatusBar = True
  .ScreenUpdating = False
  .Calculation = xlManual
End With
ThisWorkbook.Worksheets("Sheet1").UsedRange.Copy
ThisWorkbook.Worksheets("Sheet2").Paste Destination:=ThisWorkbook.Worksheets("Sheet2").Range("A1")
With ThisWorkbook.Worksheets("Sheet2").UsedRange
  lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1
  lCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
  For i = lRow To 1 Step -1
    Application.StatusBar = "Processing row " & i
    If .Cells(i, lCol).Value = .Cells(i + 1, lCol).Value Then
      For j = 1 To lCol - 1
        If Len(Trim(.Cells(i, j).Value)) > 0 Then
          .Cells(i + 1, j).Value = .Cells(i, j).Text
          Exit For
        End If
      Next
      .Rows(i).EntireRow.Delete
    End If
  Next
End With
With Application
  .Calculation = xlAutomatic
  .StatusBar = False
  .DisplayStatusBar = SBar
  .ScreenUpdating = True
End With
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Combine multiple presentations	stevevrabel	PowerPoint	27	11-23-2014 07:42 AM
Copy Multiple Rows to new workbook when multiple criteria is met.	flds	Excel Programming	5	09-30-2014 09:58 AM
Combine or merge multiple worksheets into one worksheet	timomaha	Excel	1	07-21-2014 01:02 PM
Cross-referencing in multiple documents that will combine to make one report	razberri	Word	1	01-20-2014 01:00 AM
combine multiple documents word starter 2010	bribelge	Word	3	12-19-2012 09:25 AM