Filter, Subtotal and move

[Steven123]

Hi Excel experts!

Does anyone know how to do the following with a macro.

Column B has a list of product names; and column D has amounts. e.g.

Column B Colomn D
(Product names) (Amounts)
--------------------------------
A 2
A 3
A 1
B 7
B 9
B 2
C 4
C 9

Etc.

What I need is a macro that will total the amounts per Product and if it is above 15 then move (or remove) those rows to a spreadsheet called "check".

If sounds simple enough doesn't it? But I just can't seem to get it to work.

Usually I would do it manually with a filter and then a sumproduct (and then cut / paste) but there are to many different product names to make this feasible.

If someone knows how to do this via a macro I would really really really appreciate it

Thanks ppl!
Steven123
This message was edited by Steven123 on 2002-09-27 08:45

 

[Jim North]

Hello Steven123,

You say "you can't get it to work"... do you have a macro started? If yes, post it to the board and we'll help you with it.

 

[Steven123]

I've just got it to work... It ain't pretty but it works

Thanks anyway!

 

[nick m]

I am having the same problem can you please tell me how you overcame it.
the macro would be good to

Thank you
Nick

 

[Steven123]

I took a filter macro found on this board as the basis and added an IF / Then statement. (macro consists of a public sub and a funtion). I can't remember who built the filter part but all credit for that part goes to him (or her)!

What macro does is:
1) Filter column B
2) Sum totals in column D
3) If sum is smaller that 15 than delete those rows else go to the next filtered item.

The sum only adds up visible rows (which is all we want).


Sub Filter_Delete()

Dim rng As Range
Dim n As Long
Dim o As Long
Dim Waarde As Long
Dim Bereik As Range
Dim Bereik_Kolom As Range
Dim KeyKolom As Long
Dim WaardeKolom As Long
Dim HoofdWerkblad As Worksheet
Dim NieuwWerkboek As Workbook
Dim BereikCellen As Range

With ActiveSheet
If .AutoFilterMode Then
If .FilterMode Then .ShowAllData
Else
Selection.AutoFilter
End If
End With

Set HoofdWerkblad = ActiveSheet

On Error Resume Next

Set Bereik_Kolom = Columns("B:B")

KeyKolom = Bereik_Kolom.Column
WaardeKolom = KeyKolom - ActiveSheet.AutoFilter.Range.Column + 1

Set Bereik = ActiveSheet.AutoFilter.Range
Set Bereik = Bereik.Offset(1, WaardeKolom - 1).Resize(Bereik.Rows.Count - 1, 1)

Dim myarray As Variant
myarray = make_no_dupes(Bereik)

For Waarde = LBound(myarray) To UBound(myarray)

Selection.AutoFilter Field:=WaardeKolom, Criteria1:=myarray(Waarde)

Set rng = [D2:D65500].SpecialCells(xlCellTypeVisible)
n = Application.Sum(rng)

If n < 15 Then
rng.EntireRow.Delete
End If

Next Waarde

End Sub


Function make_no_dupes(inrange As Range) As Variant

Dim Waarde As Long
Dim myarray()
Dim mycell As Range

Dim nodupes As New Collection

On Error Resume Next
For Each mycell In inrange
nodupes.Add mycell.Value, CStr(mycell.Value)
Next mycell
On Error GoTo 0

ReDim myarray(1 To nodupes.Count)
For Waarde = 1 To nodupes.Count
myarray(Waarde) = nodupes.Item(Waarde)
Next Waarde
make_no_dupes = myarray

End Function