I helped someone with something like that recently.... they started out with this:
SumOn2Cols.xls |
---|
|
---|
| A | B | C | D |
---|
1 | DEPT | DATE | DEBIT | CREDIT |
---|
2 | 5COLCP1USE | 7/2/2002 | 313.23 | 0 |
---|
3 | 5COLCP1USE | 7/2/2002 | 0 | -1730.13 |
---|
4 | 5COLCP1USE | 7/2/2002 | 0 | -3450.82 |
---|
5 | 5COLCP1USE | 7/2/2002 | 0 | -3665.65 |
---|
6 | 5COLCP1USE | 7/4/2002 | 132.12 | 0 |
---|
7 | 5COLCP1USE | 7/4/2002 | 2027.22 | 0 |
---|
|
---|
... and wanted to summarize by part no and date like this:
SumOn2Cols.xls |
---|
|
---|
| A | B | C | D |
---|
1 | DEPT | DATE | DEBIT | CREDIT |
---|
2 | 5COLCP1USE | 7/2/2002 | 313.23 | -8846.6 |
---|
3 | 5COLCP1USE | 7/4/2002 | 2159.34 | 0 |
---|
4 | | | | |
---|
|
---|
The following is the code... hope this gives you a good start!<pre>
Sub MergeRows()
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim Sell As Range
Dim CurrRow As Long
Dim KeyFld As String
Dim LastRow As Long
Dim OldRange As Range
Dim NewRow As Long
Dim LastKeyFld As String
' turn off screen updating
Application.ScreenUpdating = False
' point to the worksheets
Set wks1 = Worksheets("Sheet1")
Set wks2 = Worksheets("Sheet2")
' clear Sheet2
wks2.Columns("A:IV").Clear
' copy the headings to Sheet2
wks1.Rows("1:1").Copy
wks2.Rows("1:1").PasteSpecial Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' point to Sheet1
wks1.Activate
' get the number of rows used on Sheet1
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
NewRow = 1
' set the range to process to column A
Set OldRange = wks1.Range("A2:A" & LastRow)
For Each Sell In OldRange
CurrRow = Sell.Row
' build comparison key (Dept & Date)
KeyFld = Trim(Cells(CurrRow, 1).Value) & Trim(Cells(CurrRow, 2).Value)
If KeyFld = LastKeyFld Then
'store the debit
If Cells(CurrRow, 3).Value<> 0 Then
wks2.Range("C" & NewRow).Value = wks2.Range("C" & NewRow).Value + _
wks1.Range("C" & CurrRow).Value
End If
'store the credit
If Cells(CurrRow, 4).Value<> 0 Then
wks2.Range("D" & NewRow).Value = wks2.Range("D" & NewRow).Value + _
wks1.Range("D" & CurrRow).Value
End If
Else
LastKeyFld = KeyFld 'store the new key
NewRow = NewRow + 1 ' increment the new row for sheet2
' copy the row from sheet1 to sheet2
wks1.Range(CurrRow & ":" & CurrRow).Copy
wks2.Range(NewRow & ":" & NewRow).PasteSpecial Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Next Sell
'point to cell A1 on Sheet2
Application.CutCopyMode = False
wks2.Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub</pre>