Merge Rows of like data

[John Wright]

I get an excel sheet from our accounting department that I import into a
database for reporting. The data is straight forward in most cases, but
today I noticed that there are a lot of rows that are duplicated except for
two columns. Is there a macro or a way to run a script that would look at
these rows and compare them and if all the columns in the row match except
for these two, combine the the columns (these are number columns so I would
like to add the numbers) and create a single row? If so this would really
help me get the reports they need. Any help is appreciated. Here is an
example of the rows I would like combined

1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 6028 0 ENGSVCS
Engineering Services US US - -
1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 0 61.68 ENGSVCS
Engineering Services US US - -
1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 0 4210 ENGSVCS
Engineering Services US US - -


This is what I would like to see

1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 6028 4271.68
ENGSVCS Engineering Services US US - -



Thanks.

John

 

[Ken Johnson]

I get an excel sheet from our accounting department that I import into a
database for reporting. The data is straight forward in most cases, but
today I noticed that there are a lot of rows that are duplicated except for
two columns. Is there a macro or a way to run a script that would look at
these rows and compare them and if all the columns in the row match except
for these two, combine the the columns (these are number columns so I would
like to add the numbers) and create a single row? If so this would really
help me get the reports they need. Any help is appreciated. Here is an
example of the rows I would like combined

1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 6028 0 ENGSVCS
Engineering Services US US - -
1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 0 61.68 ENGSVCS
Engineering Services US US - -
1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 0 4210 ENGSVCS
Engineering Services US US - -

This is what I would like to see

1-Jul-07 FIRSTENERGY 605894 0 Region 21 Fuel DLGQ 32334 FA_17RFA
602381 MPFIR US MULTIPLE PLANTS FIRSTENERGY 17x17STD ENG 6028 4271.68
ENGSVCS Engineering Services US US - -

Thanks.

John

Hi John,

Try this out on a copy of your worksheet...

Option Explicit
Option Base 1
Public Sub MergeRows()
Dim TallyHeadings As Range
Set TallyHeadings = Application.InputBox( _
prompt:= _
"Select the Headings of the Columns with Values to be Added.", _
Title:= _
"Columns to be Added for Duplicate Rows", _
Default:= _
Selection.Address, _
Type:= _
8)
Dim lnHeadingDepth As Long
lnHeadingDepth = TallyHeadings.Rows.Count
Dim lnHeadingTopRow As Long
lnHeadingTopRow = TallyHeadings.Cells(1).Row
Dim TallyColumns() As Long
Dim TallyHeadingCell As Range
Dim lnTallyCol As Long
Dim T As Long
For Each TallyHeadingCell In TallyHeadings.Rows(1).Cells
lnTallyCol = lnTallyCol + 1
ReDim Preserve TallyColumns(lnTallyCol)
TallyColumns(lnTallyCol) = _
TallyHeadings.Cells(lnTallyCol).Column
Next
Dim lnLastCol As Long
Dim lnLastRow As Long
Dim I As Long, J As Long
lnLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
lnLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For I = lnHeadingDepth + lnHeadingTopRow To lnLastRow
For J = lnLastRow To I + 1 Step -1
If Not RowsAreNotDuplicates( _
TopRange:=Union(Range(Cells(I, 1), _
Cells(I, TallyColumns(1) - 1)), _
Cells(J, TallyColumns(2) + 1)), _
BottomRange:=Union(Range(Cells(J, 1), _
Cells(J, TallyColumns(1) - 1)), _
Cells(J, TallyColumns(2) + 1))) Then
For T = 1 To UBound(TallyColumns)
Cells(I, TallyColumns(T)) = Cells(I, TallyColumns(T)) + _
Cells(J, TallyColumns(T))
Next T
Cells(J, 1).EntireRow.Delete
lnLastRow = lnLastRow - 1
End If
Next J
Next I
End Sub

Public Function RowsAreNotDuplicates(TopRange As Range, _
BottomRange As Range) As Boolean
Dim Cell1 As Range, Cell2 As Range
Dim K As Long, M As Long
For Each Cell1 In TopRange
K = K + 1
For Each Cell2 In BottomRange
M = M + 1
If K = M Then
If Cell1 <> Cell2 Then
RowsAreNotDuplicates = True: Exit For
End If
End If
Next Cell2
M = 0
If RowsAreNotDuplicates Then Exit For
Next Cell1
End Function


I couldn't clearly determine the columns with the numbers to be added
so when the code is run an inputbox pops up asking the user to select
the cells containing the headings of the columns with the values that
you want added for duplicate rows.
The code assumes that these columns are contiguous.

Ken Johnson