Excel userform takes too long to process the data

C

cpereznj

New Member
Joined
Nov 27, 2012
Messages
19
Hey guys, I'm new here and have a beginners questions. I have created a userform for data entry (code below). The form takes approximately 12 seconds to transfer the data to the spreadsheet. I have tried the recommendations in the following page https://www.mrexcel.com/forum/excel-questions/496915-slow-userform.html and in http://www.cpearson.com/Excel/SuppressChangeInForms.htm. However, the code still takes the same time. Any suggestions to improve performance?

'ENABLE EVENTS
Public EnableEvents As Boolean


Private Sub UserForm_Initialize()


'ENABLE EVENTS
Me.EnableEvents = True


'Populate combo boxex
Dim rngCapexForm As Range
Dim rngTCOForm As Range
Dim rngPowerPoint As Range
Dim rngQuotes As Range
Dim rngGartner As Range
Dim rngCapexStatus As Range
Dim rngFinanceStatus As Range
Dim ws As Worksheet
Set ws = Worksheets("Dropdown Lists")

For Each rngDepartment In ws.Range("Department")
Me.cboDepartment.AddItem rngDepartment.Value
Next rngDepartment

For Each rngCapexForm In ws.Range("YesNo")
Me.cboCapexForm.AddItem rngCapexForm.Value
Next rngCapexForm

For Each rngTCOForm In ws.Range("YesNo")
Me.cboTCOForm.AddItem rngTCOForm.Value
Next rngTCOForm

For Each rngPowerPoint In ws.Range("YesNo")
Me.cboPowerPoint.AddItem rngPowerPoint.Value
Next rngPowerPoint

For Each rngQuotes In ws.Range("YesNo")
Me.cboQuotes.AddItem rngQuotes.Value
Next rngQuotes

For Each rngGartner In ws.Range("Gartner")
Me.cboGartner.AddItem rngGartner.Value
Next rngGartner

For Each rngCapexStatus In ws.Range("Status")
Me.cboCapexStatus.AddItem rngCapexStatus.Value
Next rngCapexStatus

For Each rngFinanceStatus In ws.Range("Status")
Me.cboFinanceStatus.AddItem rngFinanceStatus.Value
Next rngFinanceStatus

End Sub


Private Sub cmdAddRequest_Click()


Application.ScreenUpdating = False

'DISABLE EVENTS
Me.EnableEvents = False

'Unprotects the "Requests" worksheet
ThisWorkbook.Worksheets("Requests").Unprotect Password:=""


'Check for request name
If Trim(Me.txtRequest.Value) = "" Then
MsgBox "Please enter the name of this request or project."
Me.txtRequest.SetFocus
Exit Sub
End If


'Validate Department form field
If cboDepartment.ListIndex < 0 Then
MsgBox "Please select the department name requesting this solution from the dropdown list."
Me.cboDepartment.SetFocus
Exit Sub
End If


'Check for Sponsor name
If Trim(Me.txtSponsor.Value) = "" Then
MsgBox "Please enter the name of the person sponsoring this request."
Me.txtSponsor.SetFocus
Exit Sub
End If


'Check for Project Manager name
If Trim(Me.txtProjectManager.Value) = "" Then
MsgBox "Please enter the name of the project manager assigned to this request." & Chr(10) & _
"If no PM is required, then enter the person in charge of this implementation."
Me.txtProjectManager.SetFocus
Exit Sub
End If


'Check for Cost Amount
If txtAmount.Value = "" Then
MsgBox "Please enter the total cost of this Capex request"
Me.txtAmount.SetFocus
Exit Sub
End If


'Validate Capex Request form field
If cboCapexForm.ListIndex < 0 Then
MsgBox "Please confirm if a Capex Form was done for this request."
Me.cboCapexForm.SetFocus
Exit Sub
End If


'Validate TCO form field
If cboTCOForm.ListIndex < 0 Then
MsgBox "Please confirm if a TCO Form was done for this request."
Me.cboTCOForm.SetFocus
Exit Sub
End If

'Validate PowerPoint form field
If cboPowerPoint.ListIndex < 0 Then
MsgBox "Please confirm if a PowerPoint was done for this request."
Me.cboPowerPoint.SetFocus
Exit Sub
End If

'Validate Quotes form field
If cboQuotes.ListIndex < 0 Then
MsgBox "Please confirm if there are quotations for this request."
Me.cboQuotes.SetFocus
Exit Sub
End If

'Validate Gartner form field
If cboGartner.ListIndex < 0 Then
MsgBox "Please confirm this request has been reviewed by Gartner." & Chr(10) & _
"Some small hardware and software purchases may not have to be reviewed by them. If this is the case then select N/A."
Me.cboGartner.SetFocus
Exit Sub
End If

'Check for a date in the Date field
If txtCapexMeetingDate = "" Then
MsgBox "Please enter the date of the next Capex meeting." & Chr(10) & "Format date as mm/dd/yy."
Me.txtCapexMeetingDate.SetFocus
Exit Sub
End If


'Validate Capex Status form field
If cboCapexStatus.ListIndex < 0 Then
MsgBox "Select the proper status for this Capex request."
Me.cboCapexStatus.SetFocus
Exit Sub
End If


'Check for person added By name
If Trim(Me.txtAddedBy.Value) = "" Then
MsgBox "Please enter the name of the person adding this request to the tracker."
Me.txtAddedBy.SetFocus
Exit Sub
End If


'---------------------------------------------------------------------------------------------------------

'Enter today's date in the Date field - THIS FIELD IS LOCKED AND ONLY SENDS THE DATA
txtDate.Text = Format(Date, "mm/dd/yy")

'---------------------------------------------------------------------------------------------------------


'Copy input values to sheet.
Dim oNewRow As ListRow
Dim Rng As Range
Set Rng = ThisWorkbook.Worksheets("Requests").Range("tblCapex")
Rng.Select
Set oNewRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=True)

With ws
oNewRow.Range.Cells(1, 2).Value = Me.txtRequest.Value
oNewRow.Range.Cells(1, 3).Value = Me.cboDepartment.Value
oNewRow.Range.Cells(1, 4).Value = Me.txtSponsor.Value
oNewRow.Range.Cells(1, 5).Value = Me.txtProjectManager.Value
oNewRow.Range.Cells(1, 6).Value = Me.cboGartner.Value
oNewRow.Range.Cells(1, 7).Value = Me.txtAmount.Value
oNewRow.Range.Cells(1, 8).Value = Me.cboCapexForm.Value
oNewRow.Range.Cells(1, 9).Value = Me.cboTCOForm.Value
oNewRow.Range.Cells(1, 10).Value = Me.cboPowerPoint.Value
oNewRow.Range.Cells(1, 11).Value = Me.cboQuotes.Value
oNewRow.Range.Cells(1, 12).Value = Me.txtCapexMeetingDate.Value
oNewRow.Range.Cells(1, 13).Value = Me.cboCapexStatus.Value
oNewRow.Range.Cells(1, 15).Value = Me.cboFinanceStatus.Value
oNewRow.Range.Cells(1, 18).Value = Me.txtDocsLink.Value
oNewRow.Range.Cells(1, 19).Value = Me.txtNotes.Value
oNewRow.Range.Cells(1, 20).Value = Me.txtAddedBy.Value
oNewRow.Range.Cells(1, 21).Value = Me.txtDate.Value
End With


'---------------------------------------------------------------------------------------------------------


'Clear the data
Me.txtRequest.Value = ""
Me.cboDepartment.Value = ""
Me.txtSponsor.Value = ""
Me.txtProjectManager.Value = ""
Me.txtAmount.Value = ""
Me.cboCapexForm.Value = ""
Me.cboTCOForm.Value = ""
Me.cboPowerPoint.Value = ""
Me.cboQuotes.Value = ""
Me.cboGartner.Value = ""
Me.txtCapexMeetingDate.Value = ""
Me.cboCapexStatus.Value = ""
Me.cboFinanceStatus.Value = ""
Me.txtDocsLink.Value = ""
Me.txtNotes.Value = ""
Me.txtAddedBy.Value = ""
Me.txtDate.Value = ""

'Set focus on the Request Name field for additional data entry
Me.txtRequest.SetFocus


Application.Goto Range("A" & ActiveCell.Row), False

Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select

'---------------------------------------------------------------------------------------------------------

'Format Hyperlinks
Dim WorkRng As Range


On Error Resume Next


Set WorkRng = Application.Selection
Set WorkRng = ThisWorkbook.Worksheets("Requests").Range("tblCapex[Documentation Link]")


For Each Rng In WorkRng
Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
Next


For Each Rng In WorkRng
ThisWorkbook.Worksheets("Requests").Range ("tblCapex[Documentation Link]")
With Range("tblCapex[Documentation Link]")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.Color = vbBlue
.WrapText = True
End With
Next

'---------------------------------------------------------------------------------------------------------

'Protects the worksheet
ThisWorkbook.Worksheets("Requests").Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, _
AllowFiltering:=True, AllowUsingPivotTables:=True


Application.ScreenUpdating = True

'---------------------------------------------------------------------------------------------------------


'OPTIONAL - Close the form upon data submission to table
'Unload Me

'---------------------------------------------------------------------------------------------------------


'ENABLE EVENTS
Me.EnableEvents = True


End Sub


Private Sub cmdCloseForm_Click()
Unload Me
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
cmdCloseForm_Click
Cancel = True
MsgBox "Please use the Close Form button!"
End If
End Sub


'Format Request Date field
Private Sub txtCapexMeetingDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
txtCapexMeetingDate = Format(txtCapexMeetingDate, "mm/dd/yy")
End Sub


'Format Cost Amount field
Private Sub txtAmount_Exit(ByVal Cancel As MSForms.ReturnBoolean)
txtAmount.Value = Format(txtAmount.Value, "$#,##0.00")
End Sub
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
cpereznj, can you please throw the code into code format?
Code:
?

Also, have you tried throwing trips in at different areas to find where the main lag is generated? Throw a msgbox("1...2...4") in at different areas to see where the gap is.
 
Upvote 0
Thank you for replying so quickly Herodotus07. As mentioned in my post, I'm sort of a beginner on this matters. Not sure what you mean by posting the code in code format. Can you please tell me how do I do that?
Also, not sure how to do the msgbox to find the gaps. Can you help on this as well?
 
Upvote 0
For the code formatting, add in "
Rich (BB code): 
" just before a code block, and "
" at the end of the block (lose the "). This makes is much easier to read through posts. Also, see the examples for how to add msgbox trips. The msgbox will display at each of the locations and halt the code progress. wherever the largest delay between message boxes occurs, you can assume that is where the issues are coming from and can help narrow down the code we need to inspect.

Rich (BB code): 
Private Sub cmdAddRequest_Click()


MSGBOX("1")

Application.ScreenUpdating = False

'DISABLE EVENTS
Me.EnableEvents = False

'Unprotects the "Requests" worksheet
ThisWorkbook.Worksheets("Requests").Unprotect Password:=""


'Check for request name
If Trim(Me.txtRequest.Value) = "" Then
MsgBox "Please enter the name of this request or project."
Me.txtRequest.SetFocus
Exit Sub
End If


'Validate Department form field
If cboDepartment.ListIndex < 0 Then
MsgBox "Please select the department name requesting this solution from the dropdown list."
Me.cboDepartment.SetFocus
Exit Sub
End If


'Check for Sponsor name
If Trim(Me.txtSponsor.Value) = "" Then
MsgBox "Please enter the name of the person sponsoring this request."
Me.txtSponsor.SetFocus
Exit Sub
End If


'Check for Project Manager name
If Trim(Me.txtProjectManager.Value) = "" Then
MsgBox "Please enter the name of the project manager assigned to this request." & Chr(10) & _
"If no PM is required, then enter the person in charge of this implementation."
Me.txtProjectManager.SetFocus
Exit Sub
End If


'Check for Cost Amount
If txtAmount.Value = "" Then
MsgBox "Please enter the total cost of this Capex request"
Me.txtAmount.SetFocus
Exit Sub
End If


'Validate Capex Request form field
If cboCapexForm.ListIndex < 0 Then
MsgBox "Please confirm if a Capex Form was done for this request."
Me.cboCapexForm.SetFocus
Exit Sub
End If


'Validate TCO form field
If cboTCOForm.ListIndex < 0 Then
MsgBox "Please confirm if a TCO Form was done for this request."
Me.cboTCOForm.SetFocus
Exit Sub
End If

'Validate PowerPoint form field
If cboPowerPoint.ListIndex < 0 Then
MsgBox "Please confirm if a PowerPoint was done for this request."
Me.cboPowerPoint.SetFocus
Exit Sub
End If

'Validate Quotes form field
If cboQuotes.ListIndex < 0 Then
MsgBox "Please confirm if there are quotations for this request."
Me.cboQuotes.SetFocus
Exit Sub
End If

'Validate Gartner form field
If cboGartner.ListIndex < 0 Then
MsgBox "Please confirm this request has been reviewed by Gartner." & Chr(10) & _
"Some small hardware and software purchases may not have to be reviewed by them. If this is the case then select N/A."
Me.cboGartner.SetFocus
Exit Sub
End If

'Check for a date in the Date field
If txtCapexMeetingDate = "" Then
MsgBox "Please enter the date of the next Capex meeting." & Chr(10) & "Format date as mm/dd/yy."
Me.txtCapexMeetingDate.SetFocus
Exit Sub
End If


'Validate Capex Status form field
If cboCapexStatus.ListIndex < 0 Then
MsgBox "Select the proper status for this Capex request."
Me.cboCapexStatus.SetFocus
Exit Sub
End If


'Check for person added By name
If Trim(Me.txtAddedBy.Value) = "" Then
MsgBox "Please enter the name of the person adding this request to the tracker."
Me.txtAddedBy.SetFocus
Exit Sub
End If


'---------------------------------------------------------------------------------------------------------
MSGBOX("2")


'Enter today's date in the Date field - THIS FIELD IS LOCKED AND ONLY SENDS THE DATA
txtDate.Text = Format(Date, "mm/dd/yy")

'---------------------------------------------------------------------------------------------------------


'Copy input values to sheet.
Dim oNewRow As ListRow
Dim Rng As Range
Set Rng = ThisWorkbook.Worksheets("Requests").Range("tblCapex")
Rng.Select
Set oNewRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=True)

With ws
oNewRow.Range.Cells(1, 2).Value = Me.txtRequest.Value
oNewRow.Range.Cells(1, 3).Value = Me.cboDepartment.Value
oNewRow.Range.Cells(1, 4).Value = Me.txtSponsor.Value
oNewRow.Range.Cells(1, 5).Value = Me.txtProjectManager.Value
oNewRow.Range.Cells(1, 6).Value = Me.cboGartner.Value
oNewRow.Range.Cells(1, 7).Value = Me.txtAmount.Value
oNewRow.Range.Cells(1, 8).Value = Me.cboCapexForm.Value
oNewRow.Range.Cells(1, 9).Value = Me.cboTCOForm.Value
oNewRow.Range.Cells(1, 10).Value = Me.cboPowerPoint.Value
oNewRow.Range.Cells(1, 11).Value = Me.cboQuotes.Value
oNewRow.Range.Cells(1, 12).Value = Me.txtCapexMeetingDate.Value
oNewRow.Range.Cells(1, 13).Value = Me.cboCapexStatus.Value
oNewRow.Range.Cells(1, 15).Value = Me.cboFinanceStatus.Value
oNewRow.Range.Cells(1, 18).Value = Me.txtDocsLink.Value
oNewRow.Range.Cells(1, 19).Value = Me.txtNotes.Value
oNewRow.Range.Cells(1, 20).Value = Me.txtAddedBy.Value
oNewRow.Range.Cells(1, 21).Value = Me.txtDate.Value
End With


'---------------------------------------------------------------------------------------------------------
MSGBOX("3")

'Clear the data
Me.txtRequest.Value = ""
Me.cboDepartment.Value = ""
Me.txtSponsor.Value = ""
Me.txtProjectManager.Value = ""
Me.txtAmount.Value = ""
Me.cboCapexForm.Value = ""
Me.cboTCOForm.Value = ""
Me.cboPowerPoint.Value = ""
Me.cboQuotes.Value = ""
Me.cboGartner.Value = ""
Me.txtCapexMeetingDate.Value = ""
Me.cboCapexStatus.Value = ""
Me.cboFinanceStatus.Value = ""
Me.txtDocsLink.Value = ""
Me.txtNotes.Value = ""
Me.txtAddedBy.Value = ""
Me.txtDate.Value = ""

'Set focus on the Request Name field for additional data entry
Me.txtRequest.SetFocus


Application.Goto Range("A" & ActiveCell.Row), False

Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select

'---------------------------------------------------------------------------------------------------------

MSGBOX("4")

'Format Hyperlinks
Dim WorkRng As Range


On Error Resume Next


Set WorkRng = Application.Selection
Set WorkRng = ThisWorkbook.Worksheets("Requests").Range("tblCapex[Documentation Link]")


For Each Rng In WorkRng
Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
Next


For Each Rng In WorkRng
ThisWorkbook.Worksheets("Requests").Range ("tblCapex[Documentation Link]")
With Range("tblCapex[Documentation Link]")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.Color = vbBlue
.WrapText = True
End With
Next

'---------------------------------------------------------------------------------------------------------

'Protects the worksheet
ThisWorkbook.Worksheets("Requests").Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, _
AllowFiltering:=True, AllowUsingPivotTables:=True


Application.ScreenUpdating = True

'---------------------------------------------------------------------------------------------------------


'OPTIONAL - Close the form upon data submission to table
'Unload Me

'---------------------------------------------------------------------------------------------------------


'ENABLE EVENTS
Me.EnableEvents = True


End Sub

 
Upvote 0
Sorry, site didn't like my attempt at showing the code notation. I'll try this:

start a section of code with the word "code" surrounded by brackets, "[]". End the code section with the word "/code" surrounded by brackets.
 
Upvote 0
Hi Herodotus7, I added the message boxes and tested the results. The following are the lines of code taking the longest time:
From message box 3 (enter today's date) to message box 4 (copies data to sheet) takes approximately 4-5 seconds.
From message box 5 (clear data from form) to message box 6 (format hyperlinks) takes approximately 18 seconds.
The following is the updated code with the message boxes, and again thank you for taking the time to review.
Code: 
'THIS CODE IS TO SPEED PERFORMANCE
Public EnableEvents As Boolean


Private Sub UserForm_Initialize()


'PERFORMANCE IMPROVEMENT
    Me.EnableEvents = True


'Populate combo boxex
Dim rngCapexForm As Range
Dim rngTCOForm As Range
Dim rngPowerPoint As Range
Dim rngQuotes As Range
Dim rngGartner As Range
Dim rngCapexStatus As Range
Dim rngFinanceStatus As Range
Dim ws As Worksheet
Set ws = Worksheets("Dropdown Lists")
    
    For Each rngDepartment In ws.Range("Department")
        Me.cboDepartment.AddItem rngDepartment.Value
    Next rngDepartment
    
    For Each rngCapexForm In ws.Range("YesNo")
        Me.cboCapexForm.AddItem rngCapexForm.Value
    Next rngCapexForm
    
    For Each rngTCOForm In ws.Range("YesNo")
        Me.cboTCOForm.AddItem rngTCOForm.Value
    Next rngTCOForm
    
    For Each rngPowerPoint In ws.Range("YesNo")
        Me.cboPowerPoint.AddItem rngPowerPoint.Value
    Next rngPowerPoint
    
    For Each rngQuotes In ws.Range("YesNo")
        Me.cboQuotes.AddItem rngQuotes.Value
    Next rngQuotes
    
    For Each rngGartner In ws.Range("Gartner")
        Me.cboGartner.AddItem rngGartner.Value
    Next rngGartner
        
    For Each rngCapexStatus In ws.Range("Status")
        Me.cboCapexStatus.AddItem rngCapexStatus.Value
    Next rngCapexStatus
    
    For Each rngFinanceStatus In ws.Range("Status")
        Me.cboFinanceStatus.AddItem rngFinanceStatus.Value
    Next rngFinanceStatus
    
End Sub


Private Sub cmdAddRequest_Click()


MsgBox ("1 Command click")


    Application.ScreenUpdating = False
    
'PERFORMANCE IMPROVEMENT
    Me.EnableEvents = False
    
'Unprotects the "Capex Requests" worksheet
    ThisWorkbook.Worksheets("Capex Requests").Unprotect Password:=""


'Check for request name
    If Trim(Me.txtRequest.Value) = "" Then
        MsgBox "Please enter the name of this request or project."
        Me.txtRequest.SetFocus
        Exit Sub
    End If


'Validate Department form field
    If cboDepartment.ListIndex < 0 Then
        MsgBox "Please select the department name requesting this solution from the dropdown list."
        Me.cboDepartment.SetFocus
        Exit Sub
    End If


'Check for Sponsor name
    If Trim(Me.txtSponsor.Value) = "" Then
        MsgBox "Please enter the name of the person sponsoring this request."
        Me.txtSponsor.SetFocus
        Exit Sub
    End If


'Check for Project Manager name
    If Trim(Me.txtProjectManager.Value) = "" Then
        MsgBox "Please enter the name of the project manager assigned to this request." & Chr(10) & _
            "If no PM is required, then enter the person in charge of this implementation."
        Me.txtProjectManager.SetFocus
        Exit Sub
    End If


'Check for Cost Amount
    If txtAmount.Value = "" Then
        MsgBox "Please enter the total cost of this Capex request"
        Me.txtAmount.SetFocus
        Exit Sub
    End If


'Validate Capex Request form field
    If cboCapexForm.ListIndex < 0 Then
        MsgBox "Please confirm if a Capex Form was done for this request."
        Me.cboCapexForm.SetFocus
        Exit Sub
    End If


'Validate TCO form field
    If cboTCOForm.ListIndex < 0 Then
        MsgBox "Please confirm if a TCO Form was done for this request."
        Me.cboTCOForm.SetFocus
        Exit Sub
    End If
    
'Validate PowerPoint form field
    If cboPowerPoint.ListIndex < 0 Then
        MsgBox "Please confirm if a PowerPoint was done for this request."
        Me.cboPowerPoint.SetFocus
        Exit Sub
    End If
    
'Validate Quotes form field
    If cboQuotes.ListIndex < 0 Then
        MsgBox "Please confirm if there are quotations for this request."
        Me.cboQuotes.SetFocus
        Exit Sub
    End If
    
'Validate Gartner form field
    If cboGartner.ListIndex < 0 Then
        MsgBox "Please confirm this request has been reviewed by Gartner." & Chr(10) & _
        "Some small hardware and software purchases may not have to be reviewed by them. If this is the case then select N/A."
        Me.cboGartner.SetFocus
        Exit Sub
    End If
    
'Check for a date in the Date field
    If txtCapexMeetingDate = "" Then
        MsgBox "Please enter the date of the next Capex meeting." & Chr(10) & "Format date as mm/dd/yy."
        Me.txtCapexMeetingDate.SetFocus
        Exit Sub
    End If


'Validate Capex Status form field
    If cboCapexStatus.ListIndex < 0 Then
        MsgBox "Select the proper status for this Capex request."
        Me.cboCapexStatus.SetFocus
        Exit Sub
    End If


'Check for person added By name
    If Trim(Me.txtAddedBy.Value) = "" Then
        MsgBox "Please enter the name of the person adding this request to the tracker."
        Me.txtAddedBy.SetFocus
        Exit Sub
    End If


'---------------------------------------------------------------------------------------------------------
MsgBox ("2 Unprotects and data validations")


'Enter today's date in the Date field
    txtDate.Text = Format(Date, "mm/dd/yy")
      
'---------------------------------------------------------------------------------------------------------
MsgBox ("3 Enter today's date")


'Copy input values to sheet.
    Dim oNewRow As ListRow
    Dim Rng As Range
    Set Rng = ThisWorkbook.Worksheets("Capex Requests").Range("tblCapex")
    Rng.Select
    Set oNewRow = Selection.ListObject.ListRows.Add(AlwaysInsert:=True)
    
    With ws
        oNewRow.Range.Cells(1, 2).Value = Me.txtRequest.Value
        oNewRow.Range.Cells(1, 3).Value = Me.cboDepartment.Value
        oNewRow.Range.Cells(1, 4).Value = Me.txtSponsor.Value
        oNewRow.Range.Cells(1, 5).Value = Me.txtProjectManager.Value
        oNewRow.Range.Cells(1, 6).Value = Me.cboGartner.Value
        oNewRow.Range.Cells(1, 7).Value = Me.txtAmount.Value
        oNewRow.Range.Cells(1, 8).Value = Me.cboCapexForm.Value
        oNewRow.Range.Cells(1, 9).Value = Me.cboTCOForm.Value
        oNewRow.Range.Cells(1, 10).Value = Me.cboPowerPoint.Value
        oNewRow.Range.Cells(1, 11).Value = Me.cboQuotes.Value
        oNewRow.Range.Cells(1, 12).Value = Me.txtCapexMeetingDate.Value
        oNewRow.Range.Cells(1, 13).Value = Me.cboCapexStatus.Value
        oNewRow.Range.Cells(1, 15).Value = Me.cboFinanceStatus.Value
        oNewRow.Range.Cells(1, 18).Value = Me.txtDocsLink.Value
        oNewRow.Range.Cells(1, 19).Value = Me.txtNotes.Value
        oNewRow.Range.Cells(1, 20).Value = Me.txtAddedBy.Value
        oNewRow.Range.Cells(1, 21).Value = Me.txtDate.Value
    End With


'---------------------------------------------------------------------------------------------------------
MsgBox ("4 Copies data to sheet")


'Clear the data
    Me.txtRequest.Value = ""
    Me.cboDepartment.Value = ""
    Me.txtSponsor.Value = ""
    Me.txtProjectManager.Value = ""
    Me.txtAmount.Value = ""
    Me.cboCapexForm.Value = ""
    Me.cboTCOForm.Value = ""
    Me.cboPowerPoint.Value = ""
    Me.cboQuotes.Value = ""
    Me.cboGartner.Value = ""
    Me.txtCapexMeetingDate.Value = ""
    Me.cboCapexStatus.Value = ""
    Me.cboFinanceStatus.Value = ""
    Me.txtDocsLink.Value = ""
    Me.txtNotes.Value = ""
    Me.txtAddedBy.Value = ""
    Me.txtDate.Value = ""
    
'Set focus on the Request Name field for additional data entry
    Me.txtRequest.SetFocus


    Application.Goto Range("A" & ActiveCell.Row), False
    
    Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
    
'---------------------------------------------------------------------------------------------------------
MsgBox ("5 Clears data from form")
 
'Format Hyperlinks
Dim WorkRng As Range


On Error Resume Next


Set WorkRng = Application.Selection
Set WorkRng = ThisWorkbook.Worksheets("Capex Requests").Range("tblCapex[Documentation Link]")


    For Each Rng In WorkRng
        Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
     Next


    For Each Rng In WorkRng
        ThisWorkbook.Worksheets("Capex Requests").Range ("tblCapex[Documentation Link]")
        With Range("tblCapex[Documentation Link]")
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Font.Color = vbBlue
            .WrapText = True
        End With
    Next
    
'---------------------------------------------------------------------------------------------------------
MsgBox ("6 Formats hyperlinks")


'Protects the worksheet
    ThisWorkbook.Worksheets("Capex Requests").Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True


    Application.ScreenUpdating = True
    
'---------------------------------------------------------------------------------------------------------


'OPTIONAL - Close the form upon data submission to table
    'Unload Me
    
'---------------------------------------------------------------------------------------------------------
MsgBox ("7 Protects worksheet")
'PERFORMANFCE IMPROVEMENT
    Me.EnableEvents = True


End Sub


Private Sub cmdCloseForm_Click()
    Unload Me
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, _
    CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
    cmdCloseForm_Click
      Cancel = True
      MsgBox "Please use the Close Form button!"
    End If
End Sub


'Format Request Date field
Private Sub txtCapexMeetingDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    txtCapexMeetingDate = Format(txtCapexMeetingDate, "mm/dd/yy")
End Sub


'Format Cost Amount field
Private Sub txtAmount_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    txtAmount.Value = Format(txtAmount.Value, "$#,##0.00")
End Sub
 
Upvote 0
Two things to try first to reduce the 18 second lag. I see you are looping through the Documentation Link column twice. If you have a substantial amount of entries here, performing edits on each range can eat up time. Try:

1. Group all of the manipulations into one loop.
Code: 
For Each Rng In WorkRng
        Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
        With Rng
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Font.Color = vbBlue
            .WrapText = True
        End With
    Next

2. Do the old entries already have links in them? If so, why would you update the link? (I might be missing something, since I don't know what's in your spreadsheet). If there's no sense in updating the link, try only adding the link for the recently added item. If something else is going on, let me know.



As for the smaller lag between 3 and 4, it seems strange that its taking so long, as there isn't that much data being added. Is this being entered into a sheet table? Or just a range of cells?
 
Upvote 0
As a general note, it isn't necessary to go through all fields in a form and clear the values. To clear all values, simply add an Unload(userform) command after the data transfer is done in the calling macro.

Code: 
Sub Sample()

UserForm.Show

Unload UserForm



End Sub

This will lose all the data, where as UserForm.Hide would retain the values until the spreadsheet is closed.
 
Upvote 0
That makes sense. However, we need to keep the form open to allow the user to add multiple records. It makes it easy for data entry, instead of launching the form all the time.
The delays are when it copies the data to the sheet, when it formats the hyperlinks and when it formats the cells (this takes the longest).
Any suggestions? And again thank you for helping me with this code.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
I was try to load data To List Box And Transfer data to Sheet2.... (Not work this userform)
Replies
4
Views
190
krunal123
K
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
523
VanGirl
V
N
  • Question Question
Code taking too long to end (5 minutes) how to speed up?
Replies
1
Views
565
johnnyL
J
M
  • Question Question
I need help with this code to modify the data into a table using Userform for VBA Excel (I want to do the range unlimited instead to do C7:C80000
Replies
5
Views
651
Dan_W
D
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
584
RoryA
RoryA

Forum statistics

Threads
1,223,888
Messages
6,175,212
Members
452,618
Latest member
Tam84

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