macro tidy up

[ajm]

Hi all, if anyone has time to help me make the following macro better, more efficient, best practice, whatever-the-right-term-is, it would be greatly appreciated. User currently copies into the working file, three data sets. Each of these data sets is on its own tab and is filtered for specific records. These filtered records are then manually copied, and pasted one after the other to a new tab called "Combined". The final output is on another tab, "Final", that links to "Combined". So, please cast your eyes over this macro that copies the filtered rows from each imported dataset, and then pastes each to the Combined tab.

As it stands, the macro seems to work ok. just want to make it tighter.

This job, I am using Excel 64 bit on a Windows machine.

Sub copy_filtered_data()

With Application
    .ScreenUpdating = False ' stop screen flashing as macro runs
    .DisplayAlerts = False ' stop alert messages
    .EnableEvents = False ' disable events running
End With
   
    Dim rngTable As Range, rngCalcTable As Range, rngConvTable As Range
    Dim rCell As Range, bCell As Range, pCell As Range, visibleRows As Long, filtRows As Long, gotRows As Long
    Dim lRow As Long, nRow As Long, gRow As Long
   
    'clear existing recoreds from Combined tab.
    'can't use delete as that destroys the links on the final tab
    With Worksheets("Combined")
    .Rows("6:" & .Rows.Count).ClearContents
    End With
   
   'count visible rows
   With Worksheets("T1 Download")
    Set rngTable = .ListObjects("Table1").Range
   
        For Each rCell In rngTable.Resize(, 1).SpecialCells(xlCellTypeVisible)
            visibleRows = visibleRows + 1
        Next rCell
   
        lRow = visibleRows - 1
   
   
    End With

    'count visible rows
    With Worksheets("Calculation PPR")
    Set rngCalcTable = .ListObjects("CalcPPR").Range
   
        For Each bCell In rngCalcTable.Resize(, 1).SpecialCells(xlCellTypeVisible)
            filtRows = filtRows + 1
        Next bCell
   
        nRow = filtRows - 1
       
    End With
   
    'count visible rows
    With Worksheets("P6 Conversion to Forward Plan")
    Set rngConvTable = .ListObjects("P6ConvFwdPlan").Range
   
        For Each pCell In rngConvTable.Resize(, 1).SpecialCells(xlCellTypeVisible)
            gotRows = gotRows + 1
        Next pCell
   
        gRow = gotRows - 1
       
   
    End With

        ' copy filtered rows to Combined tab at A6
    With Worksheets("T1 Download")
    .Range("Table1").SpecialCells(xlCellTypeVisible).Copy
        Worksheets("Combined").Range("A6").PasteSpecial xlPasteValues
    End With
      
       ' copy filtered rows to Combined tab below the T1 Download data
    With Worksheets("Calculation PPR")
    .Range("CalcPPR").SpecialCells(xlCellTypeVisible).Copy
        Worksheets("Combined").Range("A" & lRow + 6).PasteSpecial xlPasteValues
     End With
       
        ' copy filtered rows to Combined tab below the T1 Download and Calc PPR data
    With Worksheets("P6 Conversion to Forward Plan")
    .Range("P6ConvFwdPlan").SpecialCells(xlCellTypeVisible).Copy
        Worksheets("Combined").Range("b" & lRow + nRow + 6).PasteSpecial xlPasteValues
     End With
    
     'format date columns
     With Worksheets("Combined")
        .Range("f6", "f" & lRow + nRow + gRow + 100).NumberFormat = "dd Mmm yy"
        .Range("q6", "g" & lRow + nRow + gRow + 100).NumberFormat = "dd Mmm yy"
        .Range("w6", "w" & lRow + nRow + gRow + 100).NumberFormat = "dd Mmm yy"
    End With
   
   
With Application
    'turn each back on
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
End With


End Sub

 

[HaHoBe]

Hi ajm,

maybe try this on a copy of the workbook:

Sub copy_filtered_data_re()
'https://www.mrexcel.com/board/threads/macro-tidy-up.1218267/

  With Application
    .ScreenUpdating = False ' stop screen flashing as macro runs
    .DisplayAlerts = False ' stop alert messages
    .EnableEvents = False ' disable events running
  End With
    
  'clear existing records from Combined tab.
  'can't use delete as that destroys the links on the final tab
  With Worksheets("Combined")
    .Rows("6:" & .Rows.Count).ClearContents
  End With
   
  With Worksheets("Combined")
    ' copy filtered rows to Combined tab at A6
    Worksheets("T1 Download").Range("Table1").SpecialCells(xlCellTypeVisible).Copy
    .Cells(6, "A").PasteSpecial xlPasteValues
    ' copy filtered rows to Combined tab below the T1 Download data
    Worksheets("Calculation PPR").Range("CalcPPR").SpecialCells(xlCellTypeVisible).Copy
    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    '/// following the comment the data should be copied in Column A while original code does so in Column B
    '/// code line for Column B is commented, if data needs to be put there feel free to comment the line above and use that line
    ' copy filtered rows to Combined tab below the T1 Download and Calc PPR data
    Worksheets("P6 Conversion to Forward Plan").Range("P6ConvFwdPlan").SpecialCells(xlCellTypeVisible).Copy
    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'    .Range("b" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
  End With
   
  'format date columns
  With Worksheets("Combined")
    .Range("F:F").NumberFormat = "dd Mmm yy"
'    .Range("f6", "f" & .Cells(.Rows.Count, "A").End(xlUp).Row + 100).NumberFormat = "dd Mmm yy"
    .Range("Q:Q").NumberFormat = "dd Mmm yy"
    .Range("W:W").NumberFormat = "dd Mmm yy"
  End With
   
  With Application
    'turn each back on
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
  End With

End Sub

Ciao,
Holger

 

[ajm]

Thanks Holger. Didn't even think of using .End(xlUp).Offset(1, 0)

 

[HaHoBe]

Hi ajm,

glad if I could help on this one. And to be honest: I remember to have worked on solutions only to be introduced to unkonwn / forgotten / not remembered by that time commands which would solve the problem more elegantly (and of course shorter) than what I had worked on.

Thanks for the feedback.
Holger