Loop and offset (i think!) within VBA

[Peteypirate]

Hopefully someone can help me with this! Have a very limited knowledge of VBA, but I'm pretty sure what I want to do can be achieved with the right knowhow!

I have the following string of code;

Range("A4:BH4961").Select
Selection.ClearContents
Range("A4").Select
Sheets("Roadside Assistance").Select
ActiveSheet.Range("$C$4970:$BJ$9927").AutoFilter Field:=1, Criteria1:="<>"
Range("C4970:C9928").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Summary").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Roadside Assistance").Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Sheets("Summary").Select
Range("A3").Select
End Sub

The section in red is what I want to loop. Each time the code loops, I'd like it to move the bits I have posted in bold by 1. so Autofilter field becomes 2, range c4970:C9928 becomes D4970:D9928 and A3 becomes B3.

I'd like it to run this 60 times and then stop.

I'm hoping this is possible and any help would be much appreciated!

 

[royUK]

Why do you need it torun 60 times?

What are filtering for.

You don't need to select sheets and ranges.

Do the ranges that you select contain data in all the cells?

Can you share a sample file with OneDrive, DropBox or similar.

 

[Peteypirate]

Hi Roy,

I need it to run 60 times as I would like it to run for 60 columns.

The filter is basically removing any blanks from the data (the number of blanks change based on other parameters on the sheet).

The selected range selects all the cells where it is possible for data to be in,- I then copy visible cells to prevent and of the blanks appearing on my summary sheet.

 

[royUK]

So do you want to end with only rows that contain data in the whole Row?

It looks like your method would copy to a summary sheet but probably end up duplicating data.

A sample of the data would be helpful

 

[Peteypirate]

How would I go about sharing the spreadsheet with you?

 

[royUK]

Upload a sample file to DropBox, OneDRive or similar. Then post the download link here

 

[Peteypirate]

The sheet is here https://www.dropbox.com/sh/c5ky8yymapqwt2t/AABhBgoVVD33p8pGnZpaUvQRa?dl=0

 

[royUK]

The cells aren't blanks, they have the value 0. Do yo want to delete all the pink rows, i.e. where the values=0

 

[royUK]

This code will delete all those rows within the table of data that contain 0.

Sub deleteFilteredData()
    Dim rDelete    As Range
    Dim lCalc  As Long
    
     
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
 On Error GoTo exit_proc
          
     'Sheet with the data, change the name
    With Sheets("Roadside Assistance")
        .AutoFilterMode = False
       
         'Apply the filter, this range of data starts in A1
        .Cells(7, 3).CurrentRegion.AutoFilter Field:=3, Criteria1:=0
         
        With .AutoFilter.Range
            On Error Resume Next
            Set rDelete = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
            .SpecialCells(xlCellTypeVisible)
'            On Error GoTo 0
            If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
        End With
         'Remove the AutoFilter
        .AutoFilterMode = False
    End With
     
exit_proc:
        .ScreenUpdating = True
        .Calculation = lCalc
    End With
     
End Sub