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 thi
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. S
the macro deletes all total sums within +/- £5

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


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

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

'

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 Sup = Nothing
Set CC = Nothing
Set RC = Nothing
' Selects the first cell in the cost centre column

Range("H2").Select

For Each Cell In Range("H:H")

' Sets active Cell = CC

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

ActiveCell.Offset(1, 0).Select

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

If Cell.Value = CC And Cell.Offset(0, 1).Value = Sup Then
AddToUnion Cell.Offset(0, 2), DelRg

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

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

' Check if Range is Nothing

If Not DelReg Is Nothing Then
DelReg.Select

' If Row Total is = 0 then delete Range

If Range.Subtotal = 0 Then
Range.EntireRow.Select.Delete x1ToLeft

End If
End If

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

ElseIf IsEmpty(ActiveCell) Then GoTo TheEnd
End If

Next Cell

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


End Sub

Sub AddToUnion(Cell As Range)
Set DelRg = Union(DelRg, Cell)
End Su

 

[Ctech]

Been working on it for a bit, its better I think. But it still doesn't
work


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

'

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 Sup = Nothing
Set CC = Nothing
Set RC = Nothing
Set DelRg = Nothing
' Selects the first cell in the cost centre column

Range("h2").Select

For Each Cell In Selection.SpecialCells(x1CellTypeConstants)

' Sets active Cell = CC

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

ActiveCell.Offset(1, 0).Select

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

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

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

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

' Check if Range is Nothing

If Not DelRg Is Nothing Then
DelRg.Select

' If Row Total is = 0 then delete Range

If DelRg.Subtotal = 0 Then
DelRg.EntireRow.Select.Delete x1ToLeft

End If
End If

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

ElseIf IsEmpty(ActiveCell) Then GoTo TheEnd
End If

Next Cell

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


End Sub

Sub AddToUnion(Cell As Range)
If DelRg Is Nothing Then
Set DelRg = Cell
Else
Set DelRg = Union(DelRg, Cell)
End If
End Sub

 

[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 Long
Dim CC As Long
Dim RC 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 Sup = Nothing
Set CC = Nothing
Set RC = Nothing
Set DelRg = Nothing
' Selects the first cell in the cost centre column

Range("H:H").Select

For Each Cell In Range("H:H")

' Sets active Cell = CC

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


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

If ActiveCell.Value = CC And ActiveCell.Offset(0, 1).Value = 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 Cell.Value = CC And Cell.Offset(0, 1).Value = Sup Then

' Check if Range is Nothing

If Not DelRg Is Nothing Then
DelRg.Select
DelRg.EntireColumn.Insert Shift:=xlToRight

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

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



End If
End If

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

ElseIf IsEmpty(ActiveCell) Then GoTo TheEnd
End If

Next Cell

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)
End If
End Sub

 

[Ctech]

Can no one help me?