VBA to copy Filtered top 10 data to another sheet

[Turbo68]

I have this started with doing some google searches and the below code works but it is copying the wrong col in my original:

'Copy Sorted TOP 10

Dim i As Long
Dim r As Range
Dim rWC As Range

Set r = Range("D16", Range("D" & Rows.Count).End(xlUp)).SpecialCells(10)

For Each rWC In r
i = i + 1
If i = 10 Or i = r.Count Then Exit For
Next rWC
Range(r(1), rWC).Resize(, 10).SpecialCells(10).Copy


Sheets("Division TOP-BOTTOM 10").Select
Range("TOP_10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

My Data looks like this:

As you can see the A is St#, B is Area, C is blank, D is the COL i want it to highlight the top 10 entries. Right now the code i am using is highlighing this:

It is not selecting the visiable cells but it is selecting 10 cells but selecting A and B col and not D either! I thought i had r= row D in the setup but not a clue why its not selcting correctly.

Major confusion here...

Any help is much appreciated.

Mike

 

[Turbo68]

'Copy Sorted TOP 10

Dim i As Long
Dim r As Range
Dim rWC As Range

Set r = Range("D16", Range("D" & Row.Count).End(xlUp)).SpecialCells(10)

For Each rWC In r
i = i + 1
If i = 10 Or i = r.Count Then Exit For
Next rWC
Range(r(1), rWC).Resize(, 12).SpecialCells(12).Copy


Sheets("Division TOP-BOTTOM 10").Select
Range("TOP_10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[Turbo68]

I think I forgot one (10) to (12)... let me run again

Nope, now not running at all...

 

[Fluff]

It should be

Dim i As Long
Dim r As Range
Dim rWC As Range

Set r = Range("D16", Range("D" & Rows.count).End(xlUp)).SpecialCells(12)

For Each rWC In r
i = i + 1
If i = 10 Or i = r.count Then Exit For
Next rWC
Range(r(1), rWC).Resize(, 10).SpecialCells(12).Select


Sheets("Division TOP-BOTTOM 10").Select
Range("TOP_10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

& if you only want column D copied, then it should be

Dim i As Long
Dim r As Range
Dim rWC As Range

Set r = Range("D16", Range("D" & Rows.count).End(xlUp)).SpecialCells(12)

For Each rWC In r
i = i + 1
If i = 10 Or i = r.count Then Exit For
Next rWC
Range(r(1), rWC).SpecialCells(12).Select


Sheets("Division TOP-BOTTOM 10").Select
Range("TOP_10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[Turbo68]

Yes, I was just writing to that effect. Changed that one 12 to 1 and got my results!!!

Thanks, Fluff for the assistance!

Mike

 

[Fluff]

You're welcome & thanks for the feedback.

 

[Turbo68]

Well, got one more question... I am going to run that code twice in one SUB but I think I need to reset the DIM I as Long, Dim r as Range, and Dim rWC as Range? It copies a lot more the 2nd time it runs that code. Is there a way to reset those without re-running another sub coding?

M

 

[Fluff]

Just put i=0 before you start the next loop & you should be ok.

 

[Turbo68]

Yep! Thanks again!

 

[Fluff]

My pleasure.