New Input Every Loop

K

kod2th3e

Board Regular
Joined
Apr 2, 2008
Messages
87
I have some code that allows a user to select multiple items from a list box and clear them out from the list. I'm trying to add a feature to allow the user to input comments for each entry if desired however the issue that I'm running into is that it will only ask for input once then it exits the loop regardless of how many items from the list box were selected. Prior to trying to add the inputbox to allow for comments the code would loop through the listbox and clear all entries that were selected just fine.

Code:

VBA Code: 
Private Sub cmdupdate_Click()
'Updates, emails, and transfers requests to completed tab
Application.ScreenUpdating = False

Dim uniqueID As String
Dim r As Long
Dim lr As Long
Dim status As String
Dim c As Range
Dim strwho As String
Dim X As Long, FoundOne As Boolean
Dim strhrcomm As String

If optapproved.Value = False And optdenied.Value = False Then
    MsgBox "Please select approved or denied for the selected request(s).", vbCritical, "Error.."
    Exit Sub
End If

For X = 0 To ListBox1.ListCount
    If ListBox1.Selected(X) Then
        FoundOne = True
        Exit For
    End If
Next
If FoundOne = False Then
    MsgBox "Please select request(s) to approve or deny.", vbCritical, "Error.."
    Exit Sub
End If

If optapproved.Value = True Then
    status = "Approved"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as approved?", vbYesNo, "Are you sure?") = vbYes Then
enterinitialsdenied:
            strwho = InputBox("Please enter your initials below:", "Initials")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitialsdenied
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                '*****************************************************************************************************************************************
                'TRYING TO INCORPORATE INPUTBOX TO ALLOW USER TO ADD COMMENTS IF DESIRED FOR EACH ENTRY **************************************************
                '*****************************************************************************************************************************************
                    strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Approved").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate
                            ActiveCell.Offset(, 15).Value = "Approved"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Approved").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optapproved.Value = False
        Else
            Exit Sub
        End If
ElseIf optdenied.Value = True Then
    status = "Denied"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as denied?", vbYesNo, "Are you sure?") = vbYes Then
enterinitials:
            strwho = InputBox("Please enter your initials below:")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitials
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                '*****************************************************************************************************************************************
                'TRYING TO INCORPORATE INPUTBOX TO ALLOW USER TO ADD COMMENTS IF DESIRED FOR EACH ENTRY **************************************************
                '*****************************************************************************************************************************************
                    strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Denied").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate
                            ActiveCell.Offset(, 15).Value = "Denied"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Denied").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optdenied.Value = False
        Else
            Exit Sub
        End If
End If
End Sub

Any thoughts/ideas on how to accomplish this task would be greatly appreciated, thank you in advance for your time.
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
Sorry I was trying to edit my original post but didn't do so successfully, below is my edit:

kod2th3e said:
I have some code that allows a user to select multiple items from a list box and clear them out from the list. I'm trying to add a feature to allow the user to input comments for each entry if desired however the issue that I'm running into is that it will only ask for input once then it exits the loop regardless of how many items from the list box were selected. Prior to trying to add the inputbox to allow for comments the code would loop through the listbox and clear all entries that were selected just fine.

Code:

VBA Code: 
Private Sub cmdupdate_Click()
'Updates, emails, and transfers requests to completed tab
Application.ScreenUpdating = False

Dim uniqueID As String
Dim r As Long
Dim lr As Long
Dim status As String
Dim c As Range
Dim strwho As String
Dim X As Long, FoundOne As Boolean
Dim strhrcomm As String

If optapproved.Value = False And optdenied.Value = False Then
    MsgBox "Please select approved or denied for the selected request(s).", vbCritical, "Error.."
    Exit Sub
End If

For X = 0 To ListBox1.ListCount
    If ListBox1.Selected(X) Then
        FoundOne = True
        Exit For
    End If
Next
If FoundOne = False Then
    MsgBox "Please select request(s) to approve or deny.", vbCritical, "Error.."
    Exit Sub
End If

If optapproved.Value = True Then
    status = "Approved"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as approved?", vbYesNo, "Are you sure?") = vbYes Then
enterinitialsdenied:
            strwho = InputBox("Please enter your initials below:", "Initials")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitialsdenied
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Approved").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate


                '*****************************************************************************************************************************************
                'TRYING TO INCORPORATE INPUTBOX TO ALLOW USER TO ADD COMMENTS IF DESIRED FOR EACH ENTRY ************************
                '*****************************************************************************************************************************************
                            strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")


                            ActiveCell.Offset(, 15).Value = "Approved"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Approved").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optapproved.Value = False
        Else
            Exit Sub
        End If
ElseIf optdenied.Value = True Then
    status = "Denied"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as denied?", vbYesNo, "Are you sure?") = vbYes Then
enterinitials:
            strwho = InputBox("Please enter your initials below:")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitials
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Denied").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate


                '*****************************************************************************************************************************************
                'TRYING TO INCORPORATE INPUTBOX TO ALLOW USER TO ADD COMMENTS IF DESIRED FOR EACH ENTRY ************************
                '*****************************************************************************************************************************************
                    strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")


                            ActiveCell.Offset(, 15).Value = "Denied"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Denied").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optdenied.Value = False
        Else
            Exit Sub
        End If
End If
End Sub

Any thoughts/ideas on how to accomplish this task would be greatly appreciated, thank you in advance for your time.
Click to expand...
 
Upvote 0
As I step through the code it appears that after it clears out the first selected item it doesn't think there are any more items in the list box selected. Almost like it's deselecting all entries after it clears out the first one then it gets stuck in an infinite loop... If I remove the input box and variable declaration for the strhrcomm it works as intended however without allowing comments to be entered.
 
Last edited:
Upvote 0
*RESOLVED*

I believe I found the issue and have updated the code (shown below) to reflect it working correctly. The issue was that I was using .rowsource rather than .list on the from initializing procedure which during the looping of the code would deselect items in the listbox because I was transferring the items to another sheet and it wouldn't recognize what was originally selected.

Code:
VBA Code: 
Private Sub cmdupdate_Click()
'Updates, emails, and transfers requests to completed tab
Application.ScreenUpdating = False

Dim uniqueID As String
Dim r As Long
Dim lr As Long
Dim status As String
Dim c As Range
Dim strwho As String
Dim X As Long, FoundOne As Boolean
Dim strhrcomm As String

If optapproved.Value = False And optdenied.Value = False Then
    MsgBox "Please select approved or denied for the selected request(s).", vbCritical, "Error.."
    Exit Sub
End If

For X = 0 To ListBox1.ListCount
    If ListBox1.Selected(X) Then
        FoundOne = True
        Exit For
    End If
Next
If FoundOne = False Then
    MsgBox "Please select request(s) to approve or deny.", vbCritical, "Error.."
    Exit Sub
End If

If optapproved.Value = True Then
    status = "Approved"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as approved?", vbYesNo, "Are you sure?") = vbYes Then
enterinitialsdenied:
            strwho = InputBox("Please enter your initials below:", "Initials")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitialsdenied
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Approved").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate
                            
                            strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")
                            
                            ActiveCell.Offset(, 15).Value = "Approved"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Approved").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optapproved.Value = False
        Else
            Exit Sub
        End If
ElseIf optdenied.Value = True Then
    status = "Denied"
        If MsgBox("Are you sure you would like to mark the highlighted item(s) on the previous form as denied?", vbYesNo, "Are you sure?") = vbYes Then
enterinitials:
            strwho = InputBox("Please enter your initials below:")
                If StrPtr(strwho) = 0 Then
                    Exit Sub
                ElseIf strwho = vbNullString Then
                    MsgBox "Please enter your initials:", vbCritical, "Error.."
                    GoTo enterinitials
                    Exit Sub
                End If
            For r = 0 To ListBox1.ListCount - 1
                If ListBox1.Selected(r) = True Then
                    uniqueID = ListBox1.List(r)
                    lr = Sheets("Denied").Range("A" & Rows.Count).End(xlUp).Row + 1
                    Windows("Electronic_TMAR.xlsm").Activate
                        Sheets("Requests").Select
                        Columns("A:A").Select
                    Cells.Find(What:=uniqueID, After:=ActiveCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False).Activate
                            strhrcomm = InputBox("Please enter any comments/notes for " & ActiveCell.Offset(, 5).Value & "'s request:", "Comments/Notes")
                            ActiveCell.Offset(, 15).Value = "Denied"
                            ActiveCell.Offset(, 16).Value = UCase(strwho)
                            ActiveCell.Offset(, 17).Value = Format(Now(), "mm/dd/yyyy")
                            ActiveCell.Offset(, 18).Value = strhrcomm
                        Range(ActiveCell, ActiveCell.Offset(, 18)).Select
                        Selection.Copy
                        Workbooks("Electronic_TMAR.xlsm").Worksheets("Denied").Cells(lr, 1).PasteSpecial Paste:=xlPasteValues
                        Selection.Delete shift:=xlUp
                        Application.CutCopyMode = False
                End If
             Next
                Call UserForm_Initialize
                optdenied.Value = False
        Else
            Exit Sub
        End If
End If
End Sub

Hopefully my troubleshooting will have helped someone else in the future, thanks for looking.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
312
sspatriots
S
D
  • Question
Helpwith my password sreadsheet please.
Replies
5
Views
467
dmt32
D
F
  • Question
Input box search by first letter of the cell value in the Column
Replies
1
Views
496
Fluff
Fluff
WildBurrow
  • Question
Copy/Paste data to next empty row within a range - WITHOUT shifting subsequent rows up
Replies
0
Views
104
WildBurrow
WildBurrow
E
  • Question
Looking for VBA to help with data collection
Replies
0
Views
513
ExcelNewbie2009
E

Forum statistics

Threads
1,214,591
Messages
6,120,429
Members
448,961
Latest member
nzskater

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