Reduce Run Time

[TryingHere]

Hi All,

I wrote some of this recorded some and pasted some that people had already written so its a bit sloppy. I'm trying to get better at VBA.

What I am trying to do is copy data from sheet 1 numbers paste to a new sheet in the same workbook so formula data is captured. Delete any columns that don't have * in row A and clear any data in rows below the last cell in column A with data. Hopefully I explained this ok. The current code I'm using below does the trick but takes about 1 minute 15 seconds to run which seems way to slow. Any thoughts for how to speed this up/ remove any unnecessary steps I'm taking?

Thank you.


Public Sub Manditory_Columns_Only()
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = "1B Data"
Sheets("1B Data").Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'delete columns
Dim c As Long

Sheets("1B Data").Activate

Application.ScreenUpdating = False

' Loop through columns backwards
For c = 105 To 1 Step -1
If Cells(1, c).Value <> "*" Then Cells(1, c).EntireColumn.Delete
Next c

Application.ScreenUpdating = True

'PricingRemoveRows()
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long

Set WS = ThisWorkbook.ActiveSheet

With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row
Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete
End With

'AddButton
Dim MyButton As button

'Add a button and assign a macro
Set MyButton = ActiveSheet.Buttons.Add(6, 7.5, 109, 22.5)
With MyButton
.Name = "RunmyCode"
.OnAction = "Delete_Tab_1B_Data" 'macro
.Characters.Text = "Delete Sheet" 'button caption
End With

Range("A2").Select
End Sub

 

[Georgiboy]

You have the below line in your code:

Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete

It seems to delete dead space at the bottom of the sheet.

As you are not dealing with a huge amount of rows/ columns, I would expect the code to be much faster.

Maybe a large part of the time saving could be selecting the right rows to take from the initial sheet, rather than using the:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Is the whole of the initial sheet formulated or is there a column where you could identify the last used row?

 

[TryingHere]

You have the below line in your code:

Rows(LastCellRowNumber + 1 & ":" & Rows.Count).Delete

It seems to delete dead space at the bottom of the sheet.

As you are not dealing with a huge amount of rows/ columns, I would expect the code to be much faster.

Maybe a large part of the time saving could be selecting the right rows to take from the initial sheet, rather than using the:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Is the whole of the initial sheet formulated or is there a column where you could identify the last used row?

The last row with a formula dragged down is 350 and i doubt that will be reached for a while. Similarly I have 90 columns and maybe will hit 120 or so max but i doubt even that. ultimately that's the max we need formatting and to clean up the data for.

 

[Georgiboy]

Do you have a column where there are just values?

Even if the formula goes further down the sheet

For example you have 350 rows with formula but a lot of the formulas refer to blank cells, I am looking for a column where the actual data ends at say row 45.

 

[TryingHere]

thanks yea at the moment the last row with necessary data is 83 and the last column is ~90. i don't expect the column numbers to change much maybe a few more added over time. Rows will be getting new data and growing but anticipate it taking a while to go even above 200.

 

[Georgiboy]

What column has the last row with necessary data? A, B, C etc..

 

[TryingHere]

ahhhh ok think i was misinterpreting the question here currently its AU.

 

[Georgiboy]

On the below code change 'Dave' in the line of code below to be the sheet name where the data is coming from:

Set wsAct = Sheets("Dave")

Then change the 'AU' in the below to be the column that has the actual values and not formula (I have already done this):

endRow = wsAct.Range("AU" & Rows.Count).End(xlUp).Row

Here is the code:

Public Sub Manditory_Columns_Only()
    Dim nWs As Worksheet, cCnt As Long, c As Long
    Dim MyButton As Button, var() As Variant, x As Long
    Dim endRow As Long, wsAct As Worksheet
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set wsAct = Sheets("Dave") ' name of the source sheet where the data is coming from
    endRow = wsAct.Range("AU" & Rows.Count).End(xlUp).Row ' last row with actual data in the source sheet taken from column A
    
    On Error Resume Next
    Set nWs = Worksheets("1B Data")
    On Error GoTo 0
    If Not nWs Is Nothing Then
        nWs.Cells.ClearContents
        nWs.Select
    Else
        Set nWs = Sheets.Add(After:=Worksheets(Sheets.Count))
        nWs.Name = "1B Data"
        
        'Add a button and assign a macro
        Set MyButton = nWs.Buttons.Add(6, 7.5, 109, 22.5)
        With MyButton
            .Name = "RunmyCode"
            .OnAction = "Delete_Tab_1B_Data" 'macro
            .Characters.Text = "Delete Sheet" 'button caption
        End With
    End If
    
    cCnt = wsAct.UsedRange.Columns.Count
    wsAct.Range(wsAct.Cells(1, 1), wsAct.Cells(endRow, cCnt)).Copy
    nWs.Range("A1").PasteSpecial xlPasteValues
    
    'Delete columns, Loop through columns backwards
    For c = cCnt To 1 Step -1
        If nWs.Cells(1, c).Value <> "*" Then nWs.Columns(c).Delete
    Next c
    
    nWs.Range("A2").Select
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[Georgiboy]

The below variables are redundant in the code above, I was trying something in the code but it didn't work. They can be removed:

var() As Variant, x As Long

 

[Alex Blakenburg]

@Georgiboy - you are going to have to at least add pasting formats and a column autofit to that.

I don't anticipate it growing too much and would want to maintain formatting.

 

[Georgiboy]

@Alex Blakenburg good spot, I missed that request.

See below, with formats and column widths:

Public Sub Manditory_Columns_Only()
    Dim nWs As Worksheet, cCnt As Long, c As Long, MyButton As Button
    Dim endRow As Long, wsAct As Worksheet
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set wsAct = Sheets("Dave") ' name of the source sheet where the data is coming from
    endRow = wsAct.Range("AU" & Rows.Count).End(xlUp).Row ' last row with actual data in the source sheet taken from column A
    
    On Error Resume Next
    Set nWs = Worksheets("1B Data")
    On Error GoTo 0
    If Not nWs Is Nothing Then
        nWs.Cells.ClearContents
        nWs.Select
    Else
        Set nWs = Sheets.Add(After:=Worksheets(Sheets.Count))
        nWs.Name = "1B Data"
        
        'Add a button and assign a macro
        Set MyButton = nWs.Buttons.Add(6, 7.5, 109, 22.5)
        With MyButton
            .Name = "RunmyCode"
            .OnAction = "Delete_Tab_1B_Data" 'macro
            .Characters.Text = "Delete Sheet" 'button caption
        End With
    End If
    
    cCnt = wsAct.UsedRange.Columns.Count
    wsAct.Range(wsAct.Cells(1, 1), wsAct.Cells(endRow, cCnt)).Copy
    With nWs.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteColumnWidths
    End With
    
    'Delete columns, Loop through columns backwards
    For c = cCnt To 1 Step -1
        If nWs.Cells(1, c).Value <> "*" Then nWs.Columns(c).Delete
    Next c
    
    nWs.Range("A2").Select
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub