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

 

[sofas]

Try this

Public Sub Manditory_Columns_Only()
    Dim WS As Worksheet, c As Long, LastCell As Range
    Dim tmp As Long, MyButton As Button

    On Error Resume Next
    Set WS = Worksheets("1B Data")
    On Error GoTo 0

    If Not WS Is Nothing Then
        WS.Cells.Clear
    Else
        ActiveSheet.Copy After:=Worksheets(Sheets.Count)
        Set WS = ActiveSheet
        WS.Name = "1B Data"
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    With WS
        .Cells.Copy
        .Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End With

    With WS
        For c = .Cells(1, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If .Cells(1, c).Value <> "*" Then
                .Cells(1, c).EntireColumn.Delete
            End If
        Next c
    End With

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

    Set MyButton = WS.Buttons.Add(6, 7.5, 109, 22.5)
    With MyButton
        .Name = "RunmyCode"
        .OnAction = "Delete_Tab_1B_Data"
        .Characters.Text = "Delete Sheet"
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    WS.Range("A2").Select
End Sub

 

[sofas]

Maybe this is faster I think

Public Sub Manditory_Columns_Only()
    Dim WS As Worksheet, c As Long, LastCell As Range
    Dim tmp As Long, MyButton As Button
    Dim DataArray As Variant, NewDataArray As Variant
    Dim i As Long, j As Long, NewColumnCount As Long

    On Error Resume Next
    Set WS = Worksheets("1B Data")
    On Error GoTo 0

    If Not WS Is Nothing Then
        On Error Resume Next
        WS.Cells.Clear
        WS.Buttons("RunmyCode").Delete
    Else
        ActiveSheet.Copy After:=Worksheets(Sheets.Count)
        Set WS = ActiveSheet
        WS.Name = "1B Data"
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    With WS
        DataArray = .UsedRange.Value
    End With

    NewColumnCount = UBound(DataArray, 2)
    For c = NewColumnCount To 1 Step -1
        If DataArray(1, c) <> "*" Then
            For i = 1 To UBound(DataArray, 1)
                DataArray(i, c) = ""
            Next i
        End If
    Next c

    WS.Cells(1, 1).Resize(UBound(DataArray, 1), UBound(DataArray, 2)).Value = DataArray

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

    Set MyButton = WS.Buttons.Add(6, 7.5, 109, 22.5)
    With MyButton
        .Name = "RunmyCode"
        .OnAction = "Delete_Tab_1B_Data"
        .Characters.Text = "Delete Sheet"
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    WS.Activate
    WS.Range("A2").Select
End Sub

 

[TryingHere]

Thanks for taking a look, your time and the quick response. Unfortunately this is just creating a new tab with no data but an unfiltered column A and two buttons the one I created and the one from the first sheet to kick off the code. Shared the new tab screenshot below.

 

[Alex Blakenburg]

The code using an array that @sofas posted in #3 doesn't work. Use Sofas's post #2

I have a working version using arrays and it is slower than what is in post #2.
If you find it is still too slow let us know and give us an indication of the number of rows and column you have.

 

[TryingHere]

However the first one you gave cuts time by about 30 seconds that's huge. It keeps one column without the * symbol at the end figuring that out and Trueing up the data now to make sure output is the same. But 40 seconds vrs 1.15 is great improvement thank you!

 

[TryingHere]

The code using an array that @sofas posted in #3 doesn't work. Use Sofas's post #2

I have a working version using arrays and it is slower than what is in post #2.
If you find it is still too slow let us know and give us an indication of the number of rows and column you have.

Thanks. Columns ~100 Rows with data to keep around 85 but that will continue to grow over time. Columns may grow a little but not too much.

 

[TryingHere]

Thanks. Columns ~100 Rows with data to keep around 85 but that will continue to grow over time. Columns may grow a little but not too much.

the columns with * data to keep after the macro currently 18. also may grow slightly but not anticipating by much.

 

[Alex Blakenburg]

How many columns are you starting out with ?
At 1.15 secs its probably not going to get much faster.
My test data has over 10k rows (deleting 200) and 53 columns which reduce down to 17 and getting around the same time as you.

Its possible that using an array on your smaller data set could be quicker but you will then lose any formatting you have in the sheet, so I don't think it would be worth it.

Did you resolve the last column with a "*" issue. It works fine for me which would indicate that you might have an additional trailing space in your last column row 1.

 

[TryingHere]

Starting with 90 Columns. I don't anticipate it growing too much and would want to maintain formatting. The 40 seconds to run is great if that's as quick as I can get it. About half the time it was taking the code I started on. The last column that is getting carried over without a star is the last column of the initial data sheet and row A header is merged column CM and CN. I uploaded two screenshots unfortunately cant share the dataset but hopefully that helps show what I'm talking about. I'm still working on that and comparing the data. This is great though. Good learning for me. Thanks again.