CODEWITHSUNDEEP
vbaexcel
user36510
user36510

Reputation: 91

Macro-button does not work like the rest

I am working on a Worksheet with a lot of different macros (approx. 20) and most of them are being successfully activated by buttons (Form controls).

My last macro is not being activated properly by the button. It looks like the macro is being run partially and then stops, but without error. If I push the "play" button in the visual basic environment it works fine.

I viewed the code behind the button and the macro is assigned correctly. I changed the button, I changed the name of the macro (no blank spaces etc.) but it did not help.

The rest still works fine, so no updates etc. involved.
Anybody have a clue what could be the issue ? The code I am using is the following:

Sub find_overdue()
    Application.ScreenUpdating = False

    Dim lr&, i&, k&

    k = 1
    Worksheets("search results").Range("A:F").ClearContents
    Worksheets("search results").Range("A:F").ClearFormats

    Worksheets("overdue").Activate
    Range("A1").Activate

    lr = Range("D" & Rows.Count).End(xlUp).Row

    k = 1

    For i = 1 To lr
        If Cells(i, "D").Value = "OVERDUE" Then
            Cells(i, "A").Copy
            Worksheets("search results").Range("A" & k).PasteSpecial Paste:=xlValues
            Cells(i, "B").Copy
            Worksheets("search results").Range("B" & k).PasteSpecial Paste:=xlValues
            Cells(i, "C").Copy
            Worksheets("search results").Range("C" & k).PasteSpecial Paste:=xlValues
            Cells(i, "D").Copy
            Worksheets("search results").Range("D" & k).PasteSpecial Paste:=xlValues

            k = k + 1
        End If
    Next i

    Worksheets("search results").Columns("A:F").AutoFit
    Worksheets("search results").Activate

    Range("A1").EntireRow.Insert

    Range("A1") = "Tag & Work"
    Range("B1") = "Last Date"
    Range("C1") = "Due Date"
    Range("D1") = "status"  

    Worksheets("search results").Range("A1:F1").Font.Bold = True
    Worksheets("search results").Range("A1:F1").HorizontalAlignment = xlCenter

    Range("B:B").NumberFormat = "dd/mm/yyyy;@"
    Range("C:C").NumberFormat = "dd/mm/yyyy;@"

    Columns("A:D").Select
    ActiveWorkbook.Worksheets("search results").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("search results").sort.SortFields.Add Key:=Range( _
      "C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
      xlSortNormal

    With ActiveWorkbook.Worksheets("search results").sort
        .SetRange Range("A:D")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Worksheets("search results").Activate
    Range("A1").Activate
End Sub

So as you can see, I am changing through two sheets ("overdue" and "search results") thus the sheet activation, my button is on a third Sheet.

Upvotes: 0

Views: 123

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57673

Removing the .Activate parts and specifying a concrete worksheet for every range should fix it.

Also don't forget to .ScreenUpdating = True in the end if you set this False in the beginning.

Option Explicit

Public Sub find_overdue()
    Application.ScreenUpdating = False

    Dim lr As Long, i As Long, k As Long

    Dim wsResults As Worksheet
    Set wsResults = Worksheets("search results")
    With wsResults.Range("A:F")
        .ClearContents
        .ClearFormats
    End If

    Dim wsOverdue As Worksheet
    Set wsOverdue = Worksheets("overdue")
    With wsOverdue
        lr = .Range("D" & .Rows.Count).End(xlUp).Row
        k = 1

        For i = 1 To lr
            If .Cells(i, "D").Value = "OVERDUE" Then
                .Cells(i, "A").Copy
                wsResults.Range("A" & k).PasteSpecial Paste:=xlValues
                .Cells(i, "B").Copy
                wsResults.Range("B" & k).PasteSpecial Paste:=xlValues
                .Cells(i, "C").Copy
                wsResults.Range("C" & k).PasteSpecial Paste:=xlValues
                .Cells(i, "D").Copy
                wsResults.Range("D" & k).PasteSpecial Paste:=xlValues

                k = k + 1
            End If
        Next i

        wsResults.Columns("A:F").AutoFit

        .Range("A1").EntireRow.Insert
        .Range("A1") = "Tag & Work"
        .Range("B1") = "Last Date"
        .Range("C1") = "Due Date"
        .Range("D1") = "status"

        wsResults.Range("A1:F1").Font.Bold = True
        wsResults.Range("A1:F1").HorizontalAlignment = xlCenter

        .Range("B:C").NumberFormat = "dd/mm/yyyy;@" 'instead of B:B and C:C we can use B:C
    End With

    With wsResults.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsResults.Range("C:C"), SortOn:=xlSortOnValues, _
           Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsResults.Range("A:D")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True 'Don't forget to activate screen updating in the end!
End Sub

Upvotes: 1

Related Questions