Speeding up a code

Good morning Happy campers,

I have the following code in a sheet.

Sub stopM()

Range("g7").Select
If Range("g7") <> "1" Then
MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
Range("C8").Select
    Exit Sub
End If
Range("C8").Select
ActiveCell.Copy
Application.Run "'Provisioning Tracker 2012 Version 110612 (2).xlsm'!Find_First"
End Sub

Sub Find_First()
    Dim FindString As String
    Dim Rng As Range
    FindString = Sheets("Input").Range("C4").Value
    If Trim(FindString) <> "" Then
        With Sheets("Work Orders").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
ActiveCell.Offset(0, 8).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
      Selection = Date
Sheets("Input").Select Range("C8").Select
Selection.ClearContents
Sheets("Input").Select Range("C4").Select
Selection.ClearContents
End Sub

This code works fine, however it takes around 20 seconds to complete. after a bit of old google searching i managed to find the following sections of code that may help.

screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation

but when i add this to my code it only does part of if, and seems to stop.

I also found that i need to enter the following at the end of my code

Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState

Could anyone let me know where these lines should go in, in order for it to work?

regards, galvinpaddy

Apologies, i have posted the wrong code strings (duh)

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

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

Hi Jeff, thanks for that, now, when running the code brings up a run-time error 1004 and highlights the following line -

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

Am i correct in thinking the data that was originally copied has now for some reason not been copied?

In short fella, the first part of the first code, C8 was copied, i then want this pasted into a cell. (the code finds the correct place to add it)

Cheers

Changed it slightly to read -

Sub stopM()

Range("g7").Select
If Range("g7") <> "1" Then
MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
Range("C8").Select
    Exit Sub
End If
Range("C8").Select
ActiveCell.Copy
Application.Run "'Provisioning Tracker 2012 Version 110612 (2).xlsm'!Find_First"
End Sub
Sub Find_First()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim FindString As String
    Dim Rng As Range
    FindString = Sheets("Input").Range("C4").Value
    If Trim(FindString) <> "" Then
        With Sheets("Work Orders").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
    Sheets("Input").Select
    Range("C8").Select
    ActiveCell.Copy
    Sheets("Work Orders").Select
    ActiveCell.Offset(0, 8).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Offset(0, 1) = Date
    With Sheets("Input")
        Range("C4, C8").ClearContents
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

This seems to run a few seconds faster, but then does not return to the original sheet and clear the contents.

Ok, so far i have managed to get the code to run VERY fast, but now cant get it to return to the starting sheet.

Sub stopM()
    ActiveSheet.Calculate
With Sheets("Input").Range("G7")
If Range("g7") <> "1" Then
MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
Range("C8").Select
    Exit Sub
End If
End With
Range("C8").Select
ActiveCell.Copy
Application.Run "'Provisioning Tracker so far.xlsm'!Find_First"
End Sub

Sub Find_First()
    Application.ScreenUpdating = False
    Dim FindString As String
    Dim Rng As Range
    FindString = Sheets("Input").Range("C4").Value
    If Trim(FindString) <> "" Then
        With Sheets("Work Orders").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
ActiveCell.Offset(0, 8).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
   ActiveCell.Offset(0, 1) = Date
    With Sheets("Input").Range("C4, C8").ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

Once the code does its thing, it wont switch back to the 'Input' sheet.

Hi Jeff,

Initially yes, but as the code progressed from a very simple copy, select sheet, paste. it was then a case of copy a line of code, insert it.
Having just had another look at it, i changed the last section of code to read

   ActiveCell.Offset(0, 1) = Date
    With Sheets("Input").Select
    Range("C4, C8").ClearContents
    End With
    With Sheets("Provision").Select
    ActiveSheet.Calculate
    Sheets("Input").Select
    End With
    Application.ScreenUpdating = True
End Sub

Now, the code runs as i want, it does take about 5-6 seconds to complete, which is a great improvement on before, but still want to know how to reduce the wait time to as little as possible (if even possible)

Kind Regards.

I know nothing about your code, but ...

ActiveCell.Offset(0, 1) = Date
    With Sheets("Input").Select
    Range("C4, C8").ClearContents
    With Sheets("Input").Select
    Range("C4, C8").ClearContents
    End With
End Sub

Normally, when you use a with statement, you use range and/or cells with a dot before them. For example:

With Sheets("Input")
    .Range("C4, C8").ClearContents
End With

Point 1: In this case all this means is:

Sheets("Input").Range("C4, C8").ClearContents

The dot (without anything else before it) connects the Range with the with statement.
So there is not much call for using a With ... End With statement for just one item.

Point 2: Without the dot, then range refers to the active sheet.

If you are trying to speed up your code, normally you shouldn't be using activecell, select, of selection.

Range("C8").Select
ActiveCell.Copy

Here is another example, just use:

Range("C8").Copy

In fact, since it is only one cell, why do you need to copy it at all?

Is there any chance you can upload your workbook?

Hi StevenM,
The reason for copying Cell C8 is i need to then paste it in another section, on Post9 above there is a link to Box.Com for the file, its almost 2mb so cant load it here.

Thanks for your input so far.

Ok, so far i have managed to get the code to run VERY fast, but now cant get it to return to the starting sheet.

Answer: Don't active any other sheet. :-) Seriously, why change to another sheet?

Hi StevenM,

Thats because the sheet will be used by members of my team, and aid damage limitation, i need to make it as easy as possible for them to complete :D

My point is this, if you have only one cell to copy, and you want to copy its value, why not:

Worksheets("Whatever").Range("Cell Address").Value = Worksheets("Where Ever").Range("Cell address").Value

Ah i see, thanks
Forgive me if i miss or dont get the point straight away, im still learning the basics for VBA :D

FindString = Sheets("Input").Range("C4").Value
If Trim(FindString) <> "" Then

Better would be:

FindString = Trim(Sheets("Input").Range("C4").Value)
If Len(FindString) Then

VBA keeps the length of each string embedded at the beginning of each string. So finding the length of a string is easy for VBA and is faster than comparing it to a zero length string. Also, 0 = False, anything else = True. Thus:

If Len(FindString) Then

Is better than If Len(FindString) > 0 Then[/CODE]

Now, about the following:

            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If

Here you should just have:

If Rng Is Nothing Then
    MsgBox "Nothing found"
    Exit Sub
End If

Now, instead of:

ActiveCell.Offset(0, 8).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
   ActiveCell.Offset(0, 1) = Date

You should have:

Rng.Offset(0, 8) = Range("C8")

Assuming that this range's worksheet is active, if not then:

Rng.Offset(0, 8) = Worksheets("Wherever").Range("C8")

Then:

Rng.Offset(0, 1) = Date

There is no need to goto the location of Rng in order to use the location of Rng.

Hi StevenM,First off, thanks alot for the detail in the above, all help greatly appreciated!
Code has been changed to

Sub stopM()
    ActiveSheet.Calculate
With Sheets("Input").Range("G7")
If Range("g7") <> "1" Then
MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
Range("C8").Select
    Exit Sub
End If
End With
Range("C8").Select
ActiveCell.Copy
Application.Run "'Provisioning Tracker so far.xlsm'!Find_First"
End Sub

Sub Find_First()
    Application.ScreenUpdating = False
    Dim FindString As String
    Dim Rng As Range
    FindString = Trim(Sheets("Input").Range("C4").Value)
    If Len(FindString) Then
        With Sheets("Work Orders").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Rng Is Nothing Then
    MsgBox "Nothing found"
    Exit Sub
End If
        End With
    End If
Rng.Offset(0, 8) = Worksheets("Input").Range("C8")
Rng.Offset(0, 1) = Date
    With Sheets("Input").Select
    Range("C4, C8").ClearContents
    End With
    With Sheets("Provision").Select
    ActiveSheet.Calculate
    Sheets("Input").Select
    End With
    Application.ScreenUpdating = True
End Sub

But still takes 6-7 seconds to run, if possible could i trouble you for more help on it?

kind regards. galvinpaddy

Sry fella, one more thing, i now no longer get the date added with

Rng.Offset(0, 1) = Date

I downloaded your workbook. If I knew what values to put in C4 & C8 to test it, I could.

I combined your two macros into one.

Assuming I didn't make some mistake, the following should work. Anyway, let me know if it does.

Sub stopM()
    Dim FindString As String
    Dim Rng As Range

    Application.ScreenUpdating = False

    ActiveSheet.Calculate
    With Sheets("Input")
        If .Range("g7") <> "1" Then
            MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
            .Range("C8").Select
            Exit Sub
        End If
    End With

    FindString = Trim(Sheets("Input").Range("C4").Value)
    If Len(FindString) = 0 Then Exit Sub
    With Sheets("Work Orders").Range("A:A")
        Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
        If Rng Is Nothing Then
            MsgBox "Nothing found"
            Exit Sub
        End If
    End With

    Rng.Offset(0, 8) = Worksheets("Input").Range("C8")
    Rng.Offset(0, 1) = Date
    Sheets("Input").Range("C4, C8").ClearContents
    Sheets("Provision").Calculate
    Application.ScreenUpdating = True
End Sub

Hi StevenM,
Thanks for that, will test shortly!
As for the info to input In C4 you can put any one 5 digit codes in ColumnA (provision tab) and then in C8 can be anything.
If for example you input the code - 13563 then a random 6 digit code in C8, click the button, then find that 6 digit code on the second tab, and you see the changes there.

Are you wanting to copy the date from Work Orders or add today's date?

Because the line:

Rng.Offset(0, 1) = Date

Adds Today's date to column "B" of the line found.

Originally Posted by StevenM

Are you wanting to copy the date from Work Orders or add today's date?

Because the line:

Rng.Offset(0, 1) = Date

Adds Today's date to column "B" of the line found.

Hi, Ideally i need to capture the days date as the code was ran (the same as =TODAY() sort of thing)

Will check the new code shortly, thanks again

The line which is slowing down your macro is:

Sheets("Provision").Calculate

So, how about just calculating the one row instead of the whole sheet? (I also made a couple other small modifications.)

Sub stopM()
    Dim FindString As String
    Dim Rng As Range
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Calculate
    With Sheets("Input")
        If .Range("g7") <> "1" Then
            MsgBox "MTN Already exists" & vbNewLine & "Please confirm Entry"
            .Range("C8").Select
            Exit Sub
        End If
    End With

    FindString = Trim(Sheets("Input").Range("C4").Value)
    If Len(FindString) = 0 Then Exit Sub
    Set Rng = Sheets("Work Orders").Range("A:A").Find(What:=FindString, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
    If Rng Is Nothing Then
        MsgBox "Nothing found"
        Exit Sub
    End If

    Rng.Offset(0, 8) = Worksheets("Input").Range("C8")
    Rng.Offset(0, 1) = Date
    Sheets("Input").Range("C4, C8").ClearContents
    
    Set Rng = Sheets("Provision").Range("A:A").Find(What:=FindString, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
    If Not Rng Is Nothing Then
        Sheets("Provision").Rows(Rng.Row).Calculate
    End If
    Application.ScreenUpdating = True
End Sub

Hi All,
Firstly - StevenM - the date part of your code was working, however i needed it to read -

Rng.Offset(0, 9) = Date

it was only by searching for todays date in the ("Work Orders") tab that i noticed it, and then it suddenly made sense!!
The code works, very well infact - runs in what seems like less than a second.

SNB - I have also tried yours and it appears to do exactly the same.

Many thanks to both, greatly appreciated.!