I have below code which has to cut the data and copy into another sheet called data_base but its not happening its copying the data in username-password.xlsx and i am facing one more problem is once i try to close the userform Logout button should appear when i click on logout button its giving error at line "Worksheets("data1").Range("B1").Value = Date & " " & Time ' as subscript out of range.
Private Sub CommandButton1_Click()
Dim username As String
Dim password As String
username = TextBox1.Text
password = TextBox2.Text
Dim info
info = IsWorkBookOpen("D:\TMS_Project\username-password.xlsx")
If info = False Then
Workbooks.Open ("D:\TMS_Project\username-password.xlsx")
End If
Dim x As Integer
x = 2
Do While Cells(x, 1).Value <> ""
If Cells(x, 1).Value = username And Cells(x, 2).Value = password Then
MsgBox "Welcome!"
Worksheets("data1").Range("A1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
UserForm1.Hide
ActiveWorkbook.Close True
End
Else
x = x + 1
End If
Loop
MsgBox "Please check your username or password!"
ActiveWorkbook.Close True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox1.SetFocus
End Sub
Private Sub CommandButton6_Click()
Worksheets("data1").Range("B1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
ThisWorkbook.Save
Worksheets("data1").Range("A1:B1").Select
Selection.Cut
Unload Me
getlogindata
ActiveWorkbook.Close True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
Sub getlogindata()
Dim info
info = IsWorkBookOpen("D:\TMS_Project\Log_Details..xlsx")
' we open the workbook if it is closed
If info = False Then
Workbooks.Open ("D:\TMS_Project\Log_Details..xlsx")
End If
Worksheets("data_base").Activate
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("data_base").Range(Cells(erow, 1), Cells(erow, 2))
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.Quit
End Sub
any help is appreciated as i got stuck at this and could not able to progress with my login and logout system.
I don't think you have a sheet called "data1" in the currently active workbook. Try fully qualifying the reference as
Workbooks("Log_Details..xlsx").worksheets("data1").range("B1")= Date & " " & Time
or Activate the desired workbook first
Related
Form 1
I am getting the code to wire to the database file but the check if the value from text box 2 is already in column B throw a message and exit is not working Also if the database is open I am not getting an error it just freezes.
Form 2
I am getting the spinning wheel. It is how it is supposed to work is if textbox1 value is already in column B add time data to column F of that row if it is textbox 1 value is not found in B throw a massage
Any help is appreciated
FORM 1 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Or TextBox2.Value = "" Or _
TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Then
MsgBox "YOU DID NOT FILL IN ALL THE INFO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Sub resetForm()
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\test.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = TextBox1.Value 'Cell
.Range("B" & iRow).Value = TextBox2.Value 'workorder number
.Range("C" & iRow).Value = TextBox3.Value 'product number
.Range("D" & iRow).Value = TextBox4.Value 'Work order quanity
.Range("E" & iRow).Value = Date 'date
.Range("F" & iRow).Value = Time 'time
.Range("M" & iRow).Value = TextBox5.Value 'crew size
Else
MsgBox "JOB ALREADY CLOCKED IN!"
Exit Sub
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End Sub
FORM 2 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Then
MsgBox "YOU DID NOT ENTER WO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\Database.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox1.Value
With wBook.Sheets("Database")
m = Application.Match(id, ("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
MsgBox "NEVER CLOCKED IN"
Exit Sub
End If
With ws.Rows(m)
.Columns("F").Value = Time
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End With
End With
End Sub
Sub resetForm()
TextBox1.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub UserForm_Click()
End Sub
If the ID values on your "database" sheet are numeric, you need to use a numeric input for Match(), so:
'Transfer the Data
id = CLng(TextBox2.Value) '<<< assuming the value is numeric: may want to add a check...
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
'etc
'etc
You don't need a separate instance of Excel to save the record - it's better to just open the file in the existing instance.
Also - if you're planning on not closing the file immediately after populating the data row, you need to check to see if it's already open when you perform the next save: opening a file which is already open can give unexpected results. See https://stackoverflow.com/a/56262538/478884
I'm really new to VBA coding. So my work requires a worksheet or form to be printed out for every production received. The current worksheet works great in generating out the form with all the details required. However, we have to batch print as we received up to 100 production at a time and its very manual to print each one. We will change the "Job number" and print it out. So I was wondering if there is any ways we could print out all at once. Take note its only one sheet each for 100 items. A loop maybe?
I will be really grateful if you have any solution to this.
Thank you
enter code here
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("STEP 1. JTW")
Set step2 = ThisWorkbook.Sheets("STEP 2. Repackaging Worksheet")
Dim n As Long, first As Long, Endd As Long
Dim lastrow As Long
Dim curvis As Long
n = Application.Match(VBA.CLng(Me.ComboBox2.Value), sh.Range("a:a"),0)
sh.Unprotect "udp"
step2.Unprotect "repackagingworksheet"
If Me.TextBox8.Value = "" Then
MsgBox "Please enter name!", vbCritical
Exit Sub
End If
Endd = Me.ComboBox3.Value
first = Me.ComboBox2.Value
sh.Range("L" & n).Value = Me.TextBox8.Value
sh.Range("M" & n).Value = Format(Now, "dd mmm yyyy hh:mm:ss")
For first = Me.ComboBox2.Value To Endd
step2.Range("f2").Value = Me.ComboBox2.Value
step2.Range("f2").Value = first
sh.Range("L" & first).Value = Me.TextBox8.Value
sh.Range("M" & first).Value = Format(Now, "dd mmm yyyy
hh:mm:ss")
With step2
.curvis = .Visible
.Visible = xlSheetVisible
.PageSetup.PrintArea = "$A$1:$D$47"
.PrintOut copies:=1, IgnorePrintAreas:=False
.Visible = curvis
End With
Next first
ActiveWorkbook.Save
Me.Hide
sh.Protect "udp", AllowFiltering:=True
step2.Protect "repackagingworksheet"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I created a data entry form in Excel.
I would like that input to be stored in another sheet (Table format).
Code I found online and modified:
Function ValidateForm() As Boolean
SellerSKU.BackColor = vbWhite
Description.BackColor = vbWhite
ValidateForm = True
If Trim(SellerSKU.Value) = "" Then
MsgBox "SKU can't be left blank.", vbOKOnly + vbInformation, "SKU"
SellerSKU.BackColor = vbRed
SellerSKU.Activate
ValidateForm = False
ElseIf Trim(Description.Value) = "" Then
MsgBox "Description can't be left blank.", vbOKOnly + vbInformation, "Description"
Description.BackColor = vbRed
Description.Activate
ValidateForm = False
End If
End Function
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
SellerSKU.Value = ""
SellerSKU.BackColor = vbWhite
Description.Value = ""
Description.BackColor = vbWhite
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim iRow As Long
iRow = Sheets("Reference Sheet (Order Hist)").Range("A1048576").End(xlUp).Row + 1
If ValidateForm = True Then
With ThisWorkbook.Sheets("Reference Sheet (Order Hist)")
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
Call Reset
Else
Application.ScreenUpdating = False
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
When I hit "Enter" on the data entry form, the table on the other sheet does not get updated.
Also is it possible to clear the form every time an entry has been successfully made?
This worked for me. Re-organized and removed some of the repetition...
Private Sub CommandButton2_Click()
Dim iRow As Long, valErrors As String
valErrors = ValidationErrors() 'checks the form
If Len(valErrors) = 0 Then
'no errors - add the data
With ThisWorkbook.Worksheets("Reference Sheet (Order Hist)")
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
ResetForm 'Call keyword is deprecated...
Else
MsgBox "One or more errors in form entries:" & vbLf & vbLf & valErrors, _
vbOKOnly + vbExclamation, "Check form data"
End If
End Sub
'check the form and return a listing of any errors
Function ValidationErrors() As String
Dim msg As String
CheckNonBlank SellerSKU, "SKU can't be left blank.", msg
CheckNonBlank Description, "Description can't be left blank.", msg
ValidationErrors = msg
End Function
'utility sub - check if a control has text, flag as error if missing,
' and add some text to the overall validation message
Sub CheckNonBlank(cntrl As Object, msgErr As String, ByRef msg As String)
Dim isErr As Boolean
isErr = Len(Trim(cntrl.Value)) = 0 'true if no content
ErrorFlag cntrl, isErr
If isErr And Len(msgErr) > 0 Then
msg = msg & IIf(Len(msg) > 0, vbLf, "") & msgErr 'append this error
End If
End Sub
Private Sub CommandButton1_Click()
ResetForm
End Sub
'clear textboxes and any error flags
Sub ResetForm()
SellerSKU.Value = ""
ErrorFlag SellerSKU, False
Description.Value = ""
ErrorFlag Description, False
End Sub
'flag a control as having a problem (pass False to second parameter to clear flag)
Sub ErrorFlag(cntrl As Object, Optional HasError As Boolean = True)
cntrl.BackColor = IIf(HasError, vbRed, vbWhite)
End Sub
i am getting object required run time error in below code at line , i checked sheet names they are correct but still showing same error Sheet1.Range("A1").Value = Date & " " & Time
Private Sub CommandButton1_Click()
Dim username As String
Dim password As String
username = TextBox1.Text
password = TextBox2.Text
Dim info
info = IsWorkBookOpen("D:\TMS_Project\username-password.xlsx")
If info = False Then
Workbooks.Open ("D:\TMS_Project\username-password.xlsx")
End If
Dim x As Integer
x = 2
Do While Cells(x, 1).Value <> ""
If Cells(x, 1).Value = username And Cells(x, 2).Value = password Then
MsgBox "Welcome!"
Sheet1.Range("A1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
UserForm1.Hide
ActiveWorkbook.Close True
End
Else
x = x + 1
End If
Loop
MsgBox "Please check your username or password!"
ActiveWorkbook.Close True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox1.SetFocus
End Sub
When you use Sheet1.Range("A1").Value, Sheet1 is actually the Worksheet.CodeName property, read here on MSDN.
While I think you meant to use the worksheet, which name is "Sheet1", then you need to use Worksheets("Sheet1").Range("A1").Value.
If you would have defined and set your Worksheet object, you would have been able to track it.
I am using the piece of code below, to verify that no one has changed my sheet's name (or deleted it).
Option Explicit
' list of worksheet names inside Workbook - easy to modify here later
Const ShtName As String = "Sheet1"
'====================================================================
Sub VerifySheetObject()
Dim Sht As Worksheet
On Error Resume Next
Set Sht = ThisWorkbook.Worksheets(ShtName)
On Error GoTo 0
If Sht Is Nothing Then ' in case someone renamed the Sheet (or it doesn't exist)
MsgBox "Sheet has been renamed, it should be " & Chr(34) & ShtName & Chr(34), vbCritical
Exit Sub
End If
' your line here
Sht.Range("A1").Value = Date & " " & Time
End Sub
To use Variables for your Sheets use:
Dim sht as Worksheet
Set sht = Worksheets("Name")
If you are refering a lot to worksheets its a must to use, but also makes it much easier to change later on.
I have a userform (uf1_assess_sched) in my Excel VBA project that has a listbox (uf1_listbox3).
When the user selects a single item in this listbox, a second userform (group_1) is opened allowing the user to enter information specific to the selection she made on the first userform. Should the user wish to abandon further entry on group_1, she can exit by clicking a commandbutton called Exit.
Upon exiting, group_1 is unloaded, and uf1_assess_sched takes the forefront. The idea is to allow the user to select another item from uf1)listbox3. However, the selection she originally made is still selected.
How do I deselect this previously made selection.
I have tried:
With uf1_assess_sched
.uf1_listbox3.listindex = -1
End With
This is the most relevant I could find in any of my searches.
Following Patrick's suggestion, with my limited understanding of Excel VBA, this is how I interpreted his instructions.
With uf1_assess_sched
For i = 0 To .uf1_listbox3.ListCount - 1
If .uf1_listbox3.Selected(i) = True Then
.uf1_listbox3.Selected(i) = False
End If
Next i
End With
This to regrettably didn't work. The code did find the true selection, but the entry remained selected in the listbox and also triggered the uf1_listbox3_Click event.
I hope I am providing feedback in the appropriate way, by simply editing my original post. I'm not sure how to add code to a comment. StackOverflow is a new format for me, so doing my best.
With the latest code so kindly provided by Patrick, I managed to get so far before I encountered an error. I made some adaptations to reflect userform and listbox names. I'm getting a "Method or data member not found. " error with the code in the second userform, group_1.
Private Sub exit1_Click()
Dim ui2 As VbMsgBoxResult
Dim lastrow As Long
Dim i As Long
If ws_vh.Range("E2") > 0 Then 'unsaved info
Me.Label34.Caption = " Saving unsaved rental data."
Me.Label34.BorderColor = RGB(50, 205, 50)
lastrow = ws_rd.Cells(ws_rd.Rows.Count, "A").End(xlUp).Row
ws_rd.Range("A3:FZ" & lastrow).Sort key1:=ws_rd.Range("A3"), order1:=xlAscending, Header:=xlNo
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Debug.Print Me.Name, "exit1_Click() called"
uf1_assess_sched.ListBox3_DeSelect '<--- Error with ".Listbox3_DeSelect"
Unload Me
'Unload group_1
'End
Exit Sub
End If
If ws_vh.Range("B2") > 0 Then 'Outstanding rentals?
ui2 = MsgBox("You still have " & ws_vh.Range("C2") & " rentals with critical missing rental information." & Chr(13) & Chr(13) _
& "Active (Sports) rentals: " & ws_vh.Range("B3") & Chr(13) & "Passive (Picnics) rentals: " & ws_vh.Range("B4") & Chr(13) & Chr(13) _
& "Are you sure you wish to exit?", vbInformation + vbYesNo, "OUTSTANDING RENTAL INFORMATION")
If ui2 = vbYes Then
If ws_vh.Range("N4") > 0 Then
Me.Label34.Caption = " Saving unsaved rental data."
Me.Label34.BorderColor = RGB(50, 205, 50)
lastrow = ws_rd.Cells(ws_rd.Rows.Count, "A").End(xlUp).Row
ws_rd.Range("A3:FZ" & lastrow).Sort key1:=ws_rd.Range("A3"), order1:=xlAscending, Header:=xlNo
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Workbooks("Sports15c.xlsm").Activate
mbEvents = False
Debug.Print Me.Name, "exit1_Click() called"
uf1_assess_sched.ListBox3_DeSelect '<--- Error with ".Listbox3_DeSelect"
Unload Me
Exit Sub
Else
Unload Me
End
End If
Else
Exit Sub
End If
End If
Unload group_1
End
End Sub
I did put the subs ListBox1_DeSelect() and ListBoxDeSelect(oListBox As Object) in a separate module (perhaps that is the problem).
Here is that code ...
Sub ListBox3_DeSelect()
ListBoxDeSelect Me.uf1_listbox3
End Sub
Private Sub ListBoxDeSelect(oListBox As Object)
Dim i As Long
If TypeName(oListBox) <> "ListBox" Then Exit Sub
bSkipEvent = True
With oListBox
For i = 0 To .ListCount - 1
If .Selected(i) Then
.Selected(i) = False
End If
Next
End With
bSkipEvent = False
End Sub
Here is my most recent code (July 19th) ...
USERFORM 1 - uf1_assess_sched (holds listbox for which which user makes selection)
Private Sub uf1_listbox3_Click()
If mbEvents Then Exit Sub
Debug.Print Me.Name, "uf1_listBox3_Click() called"
If bSkipEvent Then Exit Sub
With uf1_listbox3
Debug.Print Me.Name, "uf1_listBox3_Click() ListIndex: " & .ListIndex & " (" & .List(.ListIndex) & ")"
group_1.Show
'UserForm2.TextBox1.Value = .List(.ListIndex) ' This won't have effect if UserForm2 is True on ShowModal
End With
End Sub
USERFORM 2 - group_1 (allows user to enter additional data based on the value selected in userform1. User my opt to abandon by pressing EXIT button (exit1))
Private Sub exit1_Click()
Dim ui2 As VbMsgBoxResult
Dim lastrow As Long
Dim i As Long
If ws_vh.Range("E2") > 0 Then 'unsaved info
Me.Label34.Caption = " Saving unsaved rental data."
Me.Label34.BorderColor = RGB(50, 205, 50)
lastrow = ws_rd.Cells(ws_rd.Rows.Count, "A").End(xlUp).Row
ws_rd.Range("A3:FZ" & lastrow).Sort key1:=ws_rd.Range("A3"), order1:=xlAscending, Header:=xlNo
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Unload group_1
'End
Exit Sub
End If
If ws_vh.Range("B2") > 0 Then 'Outstanding rentals?
ui2 = MsgBox("You still have " & ws_vh.Range("C2") & " rentals with critical missing rental information." & Chr(13) & Chr(13) _
& "Active (Sports) rentals: " & ws_vh.Range("B3") & Chr(13) & "Passive (Picnics) rentals: " & ws_vh.Range("B4") & Chr(13) & Chr(13) _
& "Are you sure you wish to exit?", vbInformation + vbYesNo, "OUTSTANDING RENTAL INFORMATION")
If ui2 = vbYes Then
If ws_vh.Range("N4") > 0 Then
Me.Label34.Caption = " Saving unsaved rental data."
Me.Label34.BorderColor = RGB(50, 205, 50)
lastrow = ws_rd.Cells(ws_rd.Rows.Count, "A").End(xlUp).Row
ws_rd.Range("A3:FZ" & lastrow).Sort key1:=ws_rd.Range("A3"), order1:=xlAscending, Header:=xlNo
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Workbooks("Sports15c.xlsm").Activate
Debug.Print Me.Name, "EXIT1_Click() called"
'UserForm1.ListBox1_DeSelect ' No longer used.
Set oListBoxToDeselect = uf1_assess_sched.uf1_listbox3 ' [M2] This is required for the DelayedListBoxDeSelect(), if top right [X] is clicked, it won't do DeSelect
Unload Me
Else
Unload Me
End
End If
Else
Exit Sub
End If
End If
'If ws_vh.Range("N4") > 0 Then
' MsgBox "Unsaved rental data. Saving."
' lastrow = ws_rd.Cells(ws_rd.Rows.Count, "A").End(xlUp).row
' ws_rd.Range("A3:FZ" & lastrow).Sort key1:=ws_rd.Range("A3"), order1:=xlAscending, Header:=xlNo
' Application.DisplayAlerts = False
' ThisWorkbook.Save
' Application.DisplayAlerts = True
' Unload Me
'Else
' Worksheets("DYNAMIC").Activate
' Unload Me
'End If
'End If
Unload group_1
'Worksheets("DYNAMIC").Activate
End
End Sub
For the purpose of testing assume ws_vh.Range("B2") > 0
And the independent helper module ...
Option Explicit
' Generic ListBox Deselector
Sub ListBoxDeSelect(oListBox As Object)
Dim i As Long
If TypeName(oListBox) <> "ListBox" Then Exit Sub
bSkipEvent = True
With oListBox
For i = 0 To .ListCount - 1
If .Selected(i) Then
.Selected(i) = False
End If
Next
End With
bSkipEvent = False
End Sub
' METHOD 2 [M2] - When UserForm's ShowModal = True
Sub DelayedListBoxDeSelect()
Dim i As Long
If TypeName(oListBoxToDeselect) <> "ListBox" Then Exit Sub
bSkipEvent = True
With oListBoxToDeselect
For i = 0 To .ListCount - 1
If .Selected(i) Then
.Selected(i) = False
End If
Next
End With
bSkipEvent = False
Set oListBoxToDeselect = Nothing
End Sub
group_1 userform terminate code
Private Sub UserForm_Terminate()
Debug.Print Me.Name, "UserForm_Terminate() called"
Set oListBoxToDeselect = uf1_assess_sched.uf1_listbox3 ' [M2] This is required for the DelayedListBoxDeSelect(), if top right [X] is clicked, it won't do DeSelect
Application.OnTime Now + TimeSerial(0, 0, 1), "DelayedListBoxDeSelect" ' [M2] Sechedules the Sub named "DelayedListBoxDeSelect" to execute in 1 second.
End Sub
PART 2 - An alternate scenario requiring selection to be deselected.
If i = 0 Then
MsgBox "Nothing to eliminate."
'--- > Deselect the user selection in uf_assess_sched.uf1_listbox2 < ---
Exit Sub
End If
There are at least one way to deal with unintentional UserForm Controls Events.
As I don't know how your UserForms interact with each other, the simplest I believe is to add a Global Boolean variable to allow you skip the event when required, demonstrated below.
Edited Tip: I have taken out the Global Boolean variable bSkipEvent and Sub ListBoxDeSelect() out to a Normal Module as a code reduction, and Calls to throw in things like UserForm1.ListBox1. (Ensure the ListBox in that UserForm is Shown and Enabled, otherwise add in Error trapping code).
When UserForms ShowModal = True (TSM), a different approach is required - Onw way is to schedule a Sub to be called to alter another TSM. Here I used Application.OnTime to schedule DelayedListBoxDeSelect with 1 second right before UserForm2 is completely closed. Note the extra Public object in UserFormHelper. Hope you understand what I am doing here.
Consider these 2 simple UserForms:
After loading UserForm1 and Clicked one of the ListBox options:
Clicking on the Command Button on UserForm2 brings back focus to UserForm1:Note how the dotted selection in the ListBox1, I think it's good to leave it like that as a reminder of what was selected previously.
Codes:
UserForm1
Private Sub UserForm_Initialize()
bSkipEvent = False
End Sub
Private Sub ListBox1_Click()
Debug.Print Me.Name, "ListBox1_Click() called"
If bSkipEvent Then Exit Sub
With ListBox1
Debug.Print Me.Name, "ListBox1_Click() ListIndex: " & .ListIndex & " (" & .List(.ListIndex) & ")"
UserForm2.Show
UserForm2.TextBox1.Value = .List(.ListIndex) ' This won't have effect if UserForm2 is True on ShowModal
End With
End Sub
'Sub ListBox1_DeSelect() ' No longer used
' ListBoxDeSelect Me.ListBox1
'End Sub
UserFormsHelper (Normal Module)
Public bSkipEvent As Boolean ' This makes accessible to Userforms and other Modules
Public oListBoxToDeselect As Object '[M2] This is for delayed ListBox Deselect method
' Generic ListBox Deselector
Sub ListBoxDeSelect(oListBox As Object)
Dim i As Long
If TypeName(oListBox) <> "ListBox" Then Exit Sub
bSkipEvent = True
With oListBox
For i = 0 To .ListCount - 1
If .Selected(i) Then
.Selected(i) = False
End If
Next
End With
bSkipEvent = False
End Sub
' METHOD 2 [M2] - When UserForm's ShowModal = True
Sub DelayedListBoxDeSelect()
Dim i As Long
If TypeName(oListBoxToDeselect) <> "ListBox" Then Exit Sub
bSkipEvent = True
With oListBoxToDeselect
For i = 0 To .ListCount - 1
If .Selected(i) Then
.Selected(i) = False
End If
Next
End With
bSkipEvent = False
Set oListBoxToDeselect = Nothing
End Sub
UserForm2
Private Sub CommandButton1_Click()
Debug.Print Me.Name, "CommandButton1_Click() called"
'UserForm1.ListBox1_DeSelect ' No longer used.
Set oListBoxToDeselect = UserForm1.ListBox1 ' [M2] This is required for the DelayedListBoxDeSelect(), if top right [X] is clicked, it won't do DeSelect
Unload Me
End Sub
Private Sub UserForm_Terminate()
Debug.Print Me.Name, "UserForm_Terminate() called"
Application.OnTime Now + TimeSerial(0, 0, 1), "DelayedListBoxDeSelect" ' [M2] Sechedules the Sub named "DelayedListBoxDeSelect" to execute in 1 second.
End Sub
Debug Output