VBA to sort, select sorted cells, copy them and paste

[kubabocz]

Hi all,

I would really appreciate your help as I am struggling with one VBA, I've already spent a lot of time and I can not find the solution so I would appreciate your help a lot. Below you can find the code and the result:

Sub rcalc()
'
' rcalc Macro
'


'
    Windows("BC Template.xlsm").Activate
    Sheets("HLR").Select
    Range("D32:G39").Select
    Selection.ClearContents
    Sheets("HLR").Select
    Sheets("RCALC").Visible = True
        Sheets("RCALC").Select
    Range("A4").Select
    ActiveWorkbook.Worksheets("RCALC").AutoFilter.Sort.SortFields.Clear
    ActiveSheet.ShowAllData
    ActiveSheet.Range("$A$1:$J$101").AutoFilter Field:=10, Criteria1:="8", _
        Operator:=xlTop10Items
    Range("B1").Select
    Dim rng As Range
        Set rng = Range(Cells(ActiveCell.Row + 1, 2), Cells(Rows.Count, 1))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
        Selection.Copy
    Range("A116:D116").Select
    ActiveSheet.Paste
    Range("B1").Select
        Set rng = Range(Cells(ActiveCell.Row + 2, 2), Cells(Rows.Count, 2))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
        Application.CutCopyMode = False
    Selection.Copy
    Range("A117:D117").Select
    ActiveSheet.Paste
        Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 3, 2), Cells(Rows.Count, 3))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A118:D118").Select
    ActiveSheet.Paste
    Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 4, 2), Cells(Rows.Count, 4))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
    Selection.Copy
    Range("A119:D119").Select
    ActiveSheet.Paste
    Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 5, 2), Cells(Rows.Count, 5))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
    Selection.Copy
    Range("A120:D120").Select
    ActiveSheet.Paste
    Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 6, 2), Cells(Rows.Count, 6))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
    Selection.Copy
    Range("A121:D121").Select
    ActiveSheet.Paste
    Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 7, 2), Cells(Rows.Count, 7))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
    Selection.Copy
    Range("A122:D122").Select
    ActiveSheet.Paste
    Range("B1").Select
         Set rng = Range(Cells(ActiveCell.Row + 8, 2), Cells(Rows.Count, 8))
        rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
         Application.CutCopyMode = False
    Selection.Copy
    Range("A123:D123").Select
    ActiveSheet.Paste
    Range("A116:D123").Select
    Selection.Copy
    Sheets("HLR").Select
    Range("D32:G39").Select
    Range("D39").Activate
    ActiveSheet.Paste
    Sheets("RCALC").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("HLR").Select
    Range("D32:G32").Select
End Sub

Aim of the macro is to:
1. Unhide sheet
2. Clear sorting
3. Sort and show 8 top values
4. Copy the 8 top values and paste to the table below so it can be used in reports.

In general the problem that I am finding is that based on the filter it is choosing one line and copying it multiple times. In this case and with the values I have on the list, row 3 is copied 3 times, no idea why.

Please see below

 

[Fluff]

Re: VBA to sort, select sorted cells, copy them and paste - PLEASE HELP

How about

Sub rcalc()
   
   Windows("BC Template.xlsm").Activate
   Sheets("HLR").Range("D32:G39").ClearContents
   With Sheets("RCALC")
      .AutoFilter.Sort.SortFields.Clear
      If .FilterMode Then .ShowAllData
      .Range("$A$1:$J$101").AutoFilter Field:=10, Criteria1:="8", _
         Operator:=xlTop10Items
      Intersect(.AutoFilter.Range.Offset(1), .Range("B:B")).SpecialCells(xlVisible).Copy .Range("A116")
      Range("A116:D123").Copy Sheets("HLR").Range("D32")
   End With
   Sheets("HLR").Select
   Range("D32:G32").Select
End Sub

 

[kubabocz]

Re: VBA to sort, select sorted cells, copy them and paste - PLEASE HELP

Hi Fluff,
Unfortunately I get the debug at this place:

[COLOR=#333333]      Intersect(.AutoFilter.Range.Offset(1), .Range("B:B")).SpecialCells(xlVisible).Copy .Range("A116")[/COLOR]

Any idea why ?
Thank you

 

[Fluff]

Re: VBA to sort, select sorted cells, copy them and paste - PLEASE HELP

What was the error message?