It's getting a bit complicated

[Ctech]

hi guys

This is the aim of my macro:

1. Sort rows after "Cost center" and sort then after "Supplier". - (Done)

2. Find total sum of "Func_Value" of "suppliers" by "cost center".

3. If total sum = 0 then delete all the rows which is part of this total sum.

4. It would also be great to have the possibility to choose a limit. I.E. A MsgBox where you write in your limit as for example +/- £5. So the macro deletes all total sums within +/- £5

I hope this is understandable. If not let me know and I'll try to clerify even more.


This is my Macro so far: (I've tried to implement point 1-3 so far, but it doesn't work):

[Ctech]

See next post

[Ctech]

New update:

This time it runs through with no errors however I don't think it doe what its supposed to do.


Sub Macro1()
'
' Macro1 Macro
' Macro recorded 04/10/2005 by Taylor Nelson Sofres plc
'

'
Dim Sup As String
Dim CC As Long
Dim DelRg As Range
Dim Cell As Range



' Sort the table after Cost Centres (CC) and then after Supplier

Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom

' Setting the different Sup = Supplier - CC = Cost Centre


Set DelRg = Nothing
Sup = XX
CC = 0

' Selects the first cell in the cost centre column

Range("H2").Select

For i = 1 To 1000


' Add next row to range if it is the same CC and suppliers as the row above

If ActiveCell = CC And ActiveCell.Offset(0, 1) = Sup Then
AddToUnion ActiveCell.Offset(0, 2)



' If Row is not equal to the one above then check if Total sum of Range = 0

ElseIf Not ActiveCell = CC And ActiveCell.Offset(0, 1) = Sup Then

' Check if Range is Nothing


DelRg.EntireColumn.Select
Selected.Range.Insert Shift:=xlToRight

ActiveCell.Offset(0, 4) = "=Sum(DelRg)"


If ActiveCell.Offset(0, 4) = 0 Then
DelRg.EntireRow.Delete Shift:=x1ToLeft




ElseIf ActiveCell.Offset(0, 4) = 0 Then
DelRg.EntireRow.Delete Shift:=x1ToLeft


End If


' Checks if the cell is blank if it is GoTo End

ElseIf IsEmpty(ActiveCell) Then GoTo TheEnd
End If

CC = ActiveCell
Sup = ActiveCell.Offset(0, 1)

ActiveCell.Offset(1, 0).Select

Set DelRg = Nothing

Next i

TheEnd:
MsgBox ("All Suppliers under Cost centres which adds up to 0 is now deleted.")


End Sub

Sub AddToUnion(Cell As Range)
Dim DelRg As Range
If DelRg Is Nothing Then
Set DelRg = Cell
Else
Set DelRg = Union(DelRg, Cell)
MsgBox "This is the Range so far" & DelRg
End If
End Sub

[Ctech]

Can no one help me?