VBA Code Execution

K

KhmerBoi1

New Member
Joined
Aug 12, 2014
Messages
30
I have a procedure that was written to loop through the approximately 250 rows and place the ship name and a date in the last two open columns. The Table looks as follows:

Hull NumberShip NameSync Date
CG-2USS HOME10/3/2015
DDG-3USS Light4/23/2015
CVN-70USS Enterprise7/8/2015
PC-12USS Bunker12/7/2014
AGM-1USS Firebolt8/24/2015
LSD-89USS Staff9/24/2015
MCM-5USS Boulder (RACKU)9/24/2015

The problem I am having is when I run the procedure; it takes in the upwards of 30 min to 1 hour to run the just half of the list. The only way to quickly have the procedure finish is to make sure that Microsoft Excel is the Active Window within the Windows Environment. Tracked time from start to finish which took 100 minutes to complete code execution. How could I speed up the execution of the code? Below is the code for the procedure:

Code: 
Sub ListNIPRPlatforms()
'==========================================================================================================================
'Description: Loops through a column and add the platform names
'Originally written by: Troy Pilewski
'Date: 2015-02-01
'==========================================================================================================================
Dim lngLastRow As Long, wsSheet As Worksheet, lngLastNOC As Long, lngLastShip As Long
Dim i As Integer


'Turn off application events to speed up code
Call TOGGLEEVENTS(False)

'Sets the Datasheet as the active worksheet
If ActiveSheet Is Nothing Then
    Exit Sub
End If
 
Set wsSheet = ActiveSheet

'Determine the last row with values
lngLastRow = wsSheet.range("A:L").Find( _
    What:="*", _
    After:=wsSheet.range("A1"), _
    LookAt:=xlByRows, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row
lngLastNOC = wsSheet.range("A1:A" & lngLastRow - 15).Find( _
    What:="_", _
    After:=wsSheet.range("A1"), _
    LookAt:=xlPart, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row

lngLastShip = lngLastRow - 15

'MsgBox lngLastRow - 15
On Error Resume Next

Dim strShipname, cell As range, strFullName As String
i = lngLastNOC + 1
For Each cell In range("B" & lngLastNOC + 1 & ":B" & lngLastShip)
    With Application
        .DisplayStatusBar = True
        .StatusBar = "Working with the " & range("B" & i)
    End With
    strShipname = Split(Replace(WorksheetFunction.Clean(cell), Chr(160), " "))
    If UBound(strShipname) > 0 Then
        If Left(strShipname(0), 2) = "US" Or Left(strShipname(0), 2) = "PC" Then
            strShipname(0) = ""
        End If
        strFullName = Trim(Join(strShipname))
'        MsgBox strFullName
        Dim strUpdate As String
        If InStr(strFullName, ".") > 0 Then
            strUpdate = Left(strFullName, InStr(strFullName, " ")) & UCase(Mid(strFullName, InStr(strFullName, " ") + 1, 1)) & Mid(strFullName, InStr(strFullName, " ") + 2)
            If InStr(strUpdate, "(") > 0 Then
                Dim strTemp
                strTemp = Split(strUpdate, "(")
                strUpdate = strTemp(0) & " (" & UCase(strTemp(1))
'                MsgBox strUpdate
            End If
'            MsgBox strUpdate
            range("Q" & i).value = strUpdate
            range("R" & i).value = range("C" & i)
            range("R" & i).Select
            With Selection
                .NumberFormat = "[$-409]m/dd/yyyy"
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
            End With
'            range("S" & i).value = strUpdate
'            range("T" & i).value = range("F" & i)
'            range("T" & i).Select
'            With Selection
'                .NumberFormat = "[$-409]m/dd/yyyy"
'                .HorizontalAlignment = xlLeft
'                .VerticalAlignment = xlBottom
'            End With
        ElseIf InStr(strFullName, ".") > 1 Then
            strUpdate = Left(strFullName, InStr(strFullName, " ")) & UCase(Mid(strFullName, InStr(strFullName, " ") + 1, 1)) & Mid(strFullName, InStr(strFullName, " ") + 2)
            If InStr(strUpdate, "(") > 0 Then
                strTemp = Split(strUpdate, "(")
                strUpdate = strTemp(0) & " (" & UCase(strTemp(1))
'                MsgBox strUpdate
            End If
'            MsgBox strUpdate
            range("Q" & i).value = strUpdate
            range("R" & i).value = range("C" & i)
            range("R" & i).Select
            With Selection
                .NumberFormat = "[$-409]m/dd/yyyy"
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
            End With
'            range("S" & i).value = strUpdate
'            range("T" & i).value = range("F" & i)
'            range("T" & i).Select
'            With Selection
'                .NumberFormat = "[$-409]m/dd/yyyy"
'                .HorizontalAlignment = xlLeft
'                .VerticalAlignment = xlBottom
'            End With
        Else
            strFullName = StrConv(strFullName, vbProperCase)
            If InStr(strFullName, "(") > 0 Then
                strTemp = Split(strFullName, "(")
                strFullName = strTemp(0) & " (" & UCase(strTemp(1))
            End If
'            MsgBox strFullName
            range("Q" & i).value = strFullName
            range("R" & i).value = range("C" & i)
            range("R" & i).Select
            With Selection
                .NumberFormat = "[$-409]m/dd/yyyy"
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
            End With
'            range("S" & i).value = strFullName
'            range("T" & i).value = range("F" & i)
'            range("T" & i).Select
'            With Selection
'                .NumberFormat = "[$-409]m/dd/yyyy"
'                .HorizontalAlignment = xlLeft
'                .VerticalAlignment = xlBottom
'            End With
        End If
'        If InStr(strFullName, "(") > 0 Then
'            range("Q" & i).value = Left(strFullName, InStr(strFullName, "(") - 1) & " (" & UCase(Replace(Mid(strFullName, InStr(strFullName, "(") + 1, 999999), ")", "")) & ")"
'            range("R" & i).value = range("C" & i)
'            range("S" & i).value = range("F" & i)
'        Else
'            range("Q" & i).value = strFullName
'            range("R" & i).value = range("C" & i)
'            range("S" & i).value = range("F" & i)
'        End If
'        range("Q" & i).value = strFullName
    
    End If
    i = i + 1
Next

'For i = lngLastNOC + 1 To lngLastRow - 17
    'Dim iRetVal As Integer
    'With Application
        '.DisplayStatusBar = True
        '.StatusBar = "Working with Cell " & "Q" & i
    'End With
    'range("Q" & i).Formula = "=IFERROR(CONCATENATE(PROPER(MID(B" & i & ",5,SEARCH(""("",B" & i & ",1)-5)),MID(B" & i & ",SEARCH(""("",B" _
        & i & ",1),(LEN(B" & i & ")+1)-SEARCH(""("",B" & i & ",1))),PROPER(MID(B" & i & ", 5,LEN(B" & i & ")-4)))"
    'range("R" & i).Formula = "=C" & i
    'range("S" & i).Formula = "=F" & i
    'iRetVal = MsgBox("Is this the last record?", vbYesNo + vbDefaultButton2, "End Check!")
    'If iRetVal = vbYes Or i = lngLastRow - 1 Then
    '    Exit For
    'End If
'Next
Columns("Q:R").AutoFit
ActiveSheet.AutoFilterMode = False
ActiveSheet.range("A2:T2").Select
Selection.AutoFilter
range("I:P").EntireColumn.Hidden = True

Application.StatusBar = ""

'Turn off application events to speed up code
Call TOGGLEEVENTS(True)

End Sub


Sub TOGGLEEVENTS(blnState As Boolean)
'==========================================================================================================================
'Description: Toggles the application events for a boolean state
'Originally written by: Zack Barresse
'Date: 2014-09-15
'==========================================================================================================================


    Application.DisplayAlerts = blnState
    Application.EnableEvents = blnState
    Application.ScreenUpdating = blnState
    If blnState Then Application.CutCopyMode = False
    If blnState Then Application.StatusBar = False
End Sub

Any and all help to speed up the execution of the code would help thank you in advance...
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
Is the posted data what you start with or what you want to end up with?
 
Upvote 0
Norie said:
Is the posted data what you start with or what you want to end up with?
Click to expand...

The table is what I start with. What I should end with is:

Home10/3/2015
Light4/23/2015
Enterprise7/8/2015
Bunker12/7/2014
Firebolt8/24/2015
Staff9/24/2015
Boulder9/24/2015
 
Upvote 0
KhmerBoi1 said:
The table is what I start with. What I should end with is:

Home10/3/2015
Light4/23/2015
Enterprise7/8/2015
Bunker12/7/2014
Firebolt8/24/2015
Staff9/24/2015
Boulder9/24/2015
Click to expand...
Somehow it seems like your code is doing more than this; however, to respond to what you posted... the below code assumes your output table (the one shown above) will go to Columns H:I (change the red column references as needed)...
Code: 
Sub ListNIPRPlatforms()
  Columns("B:C").Copy Range("H1")
  Columns("[B][COLOR="#FF0000"]H[/COLOR][/B]").Replace "USS ", "", xlPart
  Columns("[B][COLOR="#FF0000"]H[/COLOR][/B]").Replace " (*", "", xlPart
  Range("[B][COLOR="#FF0000"]H[/COLOR][/B]1:[B][COLOR="#FF0000"]I[/COLOR][/B]1").Clear
End Sub
 
Upvote 0
Rick Rothstein said:
Somehow it seems like your code is doing more than this; however, to respond to what you posted... the below code assumes your output table (the one shown above) will go to Columns H:I (change the red column references as needed)...
Code: 
Sub ListNIPRPlatforms()
  Columns("B:C").Copy Range("H1")
  Columns("[B][COLOR="#FF0000"]H[/COLOR][/B]").Replace "USS ", "", xlPart
  Columns("[B][COLOR="#FF0000"]H[/COLOR][/B]").Replace " (*", "", xlPart
  Range("[B][COLOR="#FF0000"]H[/COLOR][/B]1:[B][COLOR="#FF0000"]I[/COLOR][/B]1").Clear
End Sub
Click to expand...

Mr. Rothstein,

The above tables are just examples of the data. There are some rows which refer to Hull Number Column Start with "_" character. These rows vary from week to week. This is a report that sent to me. As there is rows of information below the table that I do not need. Thus for specifying a range and looping through the range. I just don't understand why with the way that I wrote it takes so long to execute but when I start the procedure and then click on Microsoft Excel again it speeds up the execution time to just minutes as oppose to the 1hr and 40 minutes before. I'm sorry for the confusion as I've had to use really fake and confusing data.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
436
Legacy 352679
L
L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
354
RoryA
RoryA
H
  • Solved
Amend the VBA code to Filter Columns Instead of Rows
Replies
9
Views
194
Akuini
Akuini
ChristineJ
  • Solved
Adapting code to return cell values rather than cell references
Replies
2
Views
166
ChristineJ
ChristineJ
Anigito
  • Question
Get Webpage Title Text by URL Generated in MS Excel
Replies
1
Views
480
Anigito
Anigito

Forum statistics

Threads
1,215,467
Messages
6,124,985
Members
449,201
Latest member
Lunzwe73

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top