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:

[table="width: 500, class: grid, align: left"]
[tr]
[td]Hull Number[/td]
[td]Ship Name[/td]
[td]Sync Date[/td]
[/tr]
[tr]
[td]CG-2[/td]
[td]USS HOME[/td]
[td]10/3/2015[/td]
[/tr]
[tr]
[td]DDG-3[/td]
[td]USS Light[/td]
[td]4/23/2015[/td]
[/tr]
[tr]
[td]CVN-70[/td]
[td]USS Enterprise[/td]
[td]7/8/2015[/td]
[/tr]
[tr]
[td]PC-12[/td]
[td]USS Bunker[/td]
[td]12/7/2014[/td]
[/tr]
[tr]
[td]AGM-1[/td]
[td]USS Firebolt[/td]
[td]8/24/2015[/td]
[/tr]
[tr]
[td]LSD-89[/td]
[td]USS Staff[/td]
[td]9/24/2015[/td]
[/tr]
[tr]
[td]MCM-5[/td]
[td]USS Boulder (RACKU)[/td]
[td]9/24/2015[/td]
[/tr]
[/table]

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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
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:

[table="width: 500, class: grid, align: left"]
[tr]
[td]Home[/td]
[td]10/3/2015[/td]
[/tr]
[tr]
[td]Light[/td]
[td]4/23/2015[/td]
[/tr]
[tr]
[td]Enterprise[/td]
[td]7/8/2015[/td]
[/tr]
[tr]
[td]Bunker[/td]
[td]12/7/2014[/td]
[/tr]
[tr]
[td]Firebolt[/td]
[td]8/24/2015[/td]
[/tr]
[tr]
[td]Staff[/td]
[td]9/24/2015[/td]
[/tr]
[tr]
[td]Boulder[/td]
[td]9/24/2015[/td]
[/tr]
[/table]
 
Upvote 0
KhmerBoi1 said:
The table is what I start with. What I should end with is:

[table="width: 500, class: grid, align: left"]
[tr]
[td]Home[/td]
[td]10/3/2015[/td]
[/tr]
[tr]
[td]Light[/td]
[td]4/23/2015[/td]
[/tr]
[tr]
[td]Enterprise[/td]
[td]7/8/2015[/td]
[/tr]
[tr]
[td]Bunker[/td]
[td]12/7/2014[/td]
[/tr]
[tr]
[td]Firebolt[/td]
[td]8/24/2015[/td]
[/tr]
[tr]
[td]Staff[/td]
[td]9/24/2015[/td]
[/tr]
[tr]
[td]Boulder[/td]
[td]9/24/2015[/td]
[/tr]
[/table]
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

J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
239
rlv01
R
R
  • Solved
Cleaner VBA Code
Replies
4
Views
267
Joe4
Joe4
zookeepertx
  • Question Question
Having trouble "deciphering" some code so I can see how it works
Replies
7
Views
355
zookeepertx
zookeepertx
J
  • Question Question
Combining VBA Codes
Replies
4
Views
258
DanteAmor
DanteAmor
A
  • Question Question
[Excel / VBA] How do align some columns exporting to TXT?
Replies
3
Views
288
Joe4
Joe4

Forum statistics

Threads
1,223,228
Messages
6,170,874
Members
452,363
Latest member
merico17

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