VBA Code for Matching and totalling columns
 

I need to match the information in column A and then total the amounts in
column B on the matched items and move the totals that equal to zero to a new
sheet. If the total is not equal to zero then I need to just leave it as is.
Currently I am using the following loop but this is taking a long time.

Dim pos, rownum, colnum As Integer
Dim currcell As Range
Public Sub HLIST()
rownum = ActiveCell.Row
colnum = ActiveCell.Column
Set currcell = ActiveSheet.Cells(rownum, colnum)
End Sub
Range("A6").Select
Selection.End(xlDown).Select
Calculate
Sheets("table").Select
Range("A1").Select
pos = ActiveCell
Sheets("Outstanding").Select
Rows("6:" & pos).Select
' comparing by for sum total equal zero to move to accum cleared items
Selection.sort Key1:=Range("C1"), Order1:=xlAscending,
Key2:=Range("A1"), Order2:=xlAscending, Key3:=Range("H1"),
Order3:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
Sheets("outstanding").Select
' look for unmatch and insert line to put totals
Range("C6").Select
Call HLIST
counter = 1
Do While currcell < ""
If currcell.Offset(0, 0) = currcell.Offset(1, 0) Then
rownum = rownum + 1
Else
rownum = rownum + 1
POS1 = rownum
Range("a" & POS1).EntireRow.Insert
Calculate
pos2 = counter
pos3 = pos2 - POS1
pos4 = -1
Range("h" & POS1).FormulaR1C1 = "=round(sum(r[" & pos3 & "]c:r[" &
pos4 & "]c),2)"
Range("h" & POS1).Copy
Range("h" & POS1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
' if totals equals zero then remove from compare
If ActiveCell = 0 Then
Sheets("outstanding").Select
Range("A" & POS1 - 1 & ":N" & pos2).Cut
Sheets("ACCUM CLEARED ITEMS").Select
Range("A" & posclr).Select
ActiveSheet.Paste
Application.Goto Reference:="R65000C1"
Selection.End(xlUp).Select
Calculate
Sheets("table").Select
Range("a1").Select
posclr = ActiveCell + 1
Sheets("outstanding").Select
Range("A" & POS1 & ":N" & pos2).Delete Shift:=xlUp
Range("a" & counter).Select
Calculate
rownum = counter
Else
' if total not equal to zero then keep and delete total line
Rows(POS1 & ":" & POS1).Delete
counter = rownum
End If
End If
Set currcell = ActiveSheet.Cells(rownum, colnum)
Loop

Any suggestions would be greatly appreciated.


example.
column A Column B
yellow 5.00
red 10.00
blue 10.00
red -20.00
blue 40.00
yellow -5.00

Result:
Sheet1
column A Column B
red 10.00
blue 10.00
red -20.00
blue 40.00

Sheet2
column A Column B
yellow 5.00
yellow -5.00