Updating form responses from one sheet to another - excel

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

Related

Delete row after application.match

I can't figure out why it is not deleting the row if the user selects no.
I even tried telling to delete a certain line in the ws but it still did not delete that row
Adding the data if it is not there works.
If it is already there the message box does pop up.
The only function that is not working is the delete.
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim ws As Worksheet, id, v, m
Dim FileName As String
Dim CurrentJob As Long
Dim CurrentRow As Variant '<--- NOTE
Dim CurrentCell As Variant
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
TryWriteMode book:=wBook _
, numberOfTries:=4 _
, secondsWaitAfterFailedTry:=10
' MsgBox "test", vbInformation
End If
If wBook.ReadOnly Then
MsgBox "Database is in use. Please try again later.", vbOKOnly + vbInformation, "Read-only book"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("database")
Set ws = wBook.Sheets("database")
' m = Application.Match(id, ws.[B:B], 0) 'try to match an existing row
m = Application.Match(id, 5, 0)
CurrentJob = TextBox2.Value
CurrentRow = Application.Match(CurrentJob, ws.Range("B:B"), 0)
CurrentCell = ws.Cells(CurrentRow, 1)
If IsError(CurrentRow) Then
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
Else
MsgBox "JOB ALREADY ASSIGNED TO " & CurrentCell & vbNewLine & "DO YOU WANT TO KEEP IT THIER ", vbYesNo
If Result = vbNo Then
ws.Rows(CurrentRow).EntireRow.Delete
End If
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
End Sub

compare input text to cell and get row in external document

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

Looping for dynamic pictures

So I have created a dynamic selection list for excel using vba. see below
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call PanggilPhoto
End If
End Sub
Sub PanggilPhoto()
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T As String
myDir = ThisWorkbook.Path & "\"
CommodityName1 = Range("A2")
T = ".png"
Range("C15").Value = CommodityName
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=10, Width:=140,
Height:=90
errormessage:If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"
Range("A2").Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
End Sub
foto is a predefined data list in the sheet.
So the question is instead of doing it for one cell how can I create a loop of some sort to do it for multiple cells? I need it to import mulitple images on one macro run
found a solution
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call schedules
End If
End Sub
Sub schedules()
Worksheets("Picture").Activate
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
Dim i As Integer, j As Integer, k As Integer
j = 0
For i = 2 To 100
myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("A" & i)
T1 = ".png"
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80
errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
Range("A" & i).Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
i = i + 11
j = j + 190
Next i
End Sub

Excel VBA - How To Deselect A Previosuly Selected Item In A Listbox

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

Search command button on userform not working correctly

I have a search button on a userform. I want 3 things to happen. If the user selects the Search button without putting any text in TextBox6, I want a msgbox to popup and tell them they need to add a customer code. If they enter a customer code that is not in the excel spreadsheet and select the Search button, I want a msgbox to popup and tell them that customer code doesn't exist. When they select OK I want TextBox6 to clear and the cursor to have focus set on TextBox6. If they enter a code in TextBox6 that is in the excel spreadsheet and select the Search button, I want that record to populate the userform. I am using the code below, and it works for scenario 1 and 2 above. But when the code exists in the excel spreadsheet, after it populates the userform the msgbox that says the that customer code doesn't exist still popsup. Can you adjust my code so that doesn't happen?
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim strSearch As String
Dim aCell As Range
On Error GoTo Err
'validate text box
If TextBox6.Value = "" Then
MsgBox "Please Enter Customer Code"
Cancel = True
Me.TextBox6.SetFocus
Else
row_number = 0
Do
DoEvents
row_number = row_number + 1
items_in_review = Sheets("sheet1").Range("A" & row_number)
If items_in_review = TextBox6.Text Then
TextBox1.Text = Sheets("sheet1").Range("B" & row_number)
TextBox2.Text = Sheets("sheet1").Range("C" & row_number)
TextBox3.Text = Sheets("sheet1").Range("D" & row_number)
TextBox4.Text = Sheets("sheet1").Range("F" & row_number)
TextBox5.Text = Sheets("sheet1").Range("H" & row_number)
TextBox7.Text = Sheets("sheet1").Range("I" & row_number)
TextBox8.Text = Sheets("sheet1").Range("G" & row_number)
Me.TextBox7.Visible = True
Me.Label8.Visible = True
End If
Loop Until items_in_review = ""
MsgBox "Customer Code not Found"
Cancel = True
UserForm1.TextBox6.Value = ""
TextBox6.SetFocus
Exit Sub
Err:
MsgBox Err.Description
End If
End Sub
I prefer not to clear the search box if something is not found: as a user it's annoying if you have to retype the whole thing just because you made a typo...
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim strSearch As String
Dim aCell As Range, v
On Error GoTo Err
'validate text box
v = Trim(TextBox6.Value)
If Len(v) = 0 Then
MsgBox "Please Enter Customer Code"
Cancel = True
Me.TextBox6.SetFocus
Exit Sub
End if
Set aCell = Sheets("sheet1").Range("A:A").Find(v, lookat:=xlWhole)
if not aCell is Nothing Then
with aCell.EntireRow
TextBox1.Text = .Cells(,"B").Value
TextBox2.Text = .Cells(,"C").Value
TextBox3.Text = .Cells(,"D").Value
TextBox4.Text = .Cells(,"F").Value
TextBox5.Text = .Cells(,"H").Value
TextBox7.Text = .Cells(,"I").Value
TextBox8.Text = .Cells(,"G").Value
end with
Me.TextBox7.Visible = True
Me.Label8.Visible = True
else
MsgBox "Customer Code not Found"
Cancel = True
'UserForm1.TextBox6.Value = "" 'don't do this!
TextBox6.SetFocus
end if
Exit Sub
Err:
MsgBox Err.Description
End Sub

Resources