C
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
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