Search and edit records using userform - excel

i'm relatively new to VBA and have muddled my way through to almost achieving the system i set out to produce.
I have now reached a brick wall and have been smashing my head against it for some time, help with my paradigm (tome only i'm sure) would be very much appreciated!!
So i am able to search for records and populate my user form from that, what i would like to do is update the found record through the same form when clicking the update button which is present on said user form.
Private Sub btsearch_Click()
Dim totrows As Long
totrows = Worksheets("Report").Range("A1").CurrentRegion.Rows.Count
If Txtforename.Text = "" Then
MsgBox "Please enter guest name!!"
End If
For i = 2 To totrows
If Trim(Report.Cells(i, 1)) <> Trim(Txtforename.Text) And i = totrows Then
MsgBox "Guest Not Found"
End If
If Trim(Report.Cells(i, 1)) = Trim(Txtforename.Text) Then
Txtforename.Text = Report.Cells(i, 1)
Txtsurename.Text = Report.Cells(i, 2)
Cboidtype.Text = Report.Cells(i, 3)
txtidnumber.Text = Report.Cells(i, 4)
Cboroomno.Text = Report.Cells(i, 5)
txtcheckin.Text = Report.Cells(i, 6)
txtcheckout.Text = Report.Cells(i, 7)
Cbopaymenttype.Text = Report.Cells(i, 9)
Txttotalpayment.Text = Report.Cells(i, 10)
cmbouser.Text = Report.Cells(i, 11)
Exit For
End If
Next i
End Sub
Private Sub btnupdate_Click()
answer = MsgBox("Would you like to update guest details?", vbYesNo +
vbQuestion, "Update Record")
If answer = vbYes Then
Cells(currentrow, 1) = Txtforename.Text
Cells(currentrow, 2) = Txtsurename.Text
Cells(currentrow, 3) = Cboidtype.Text
Cells(currentrow, 4) = txtidnumber.Text
Cells(currentrow, 5) = Cboroomno.Text
Cells(currentrow, 6) = txtcheckin.Text
Cells(currentrow, 7) = txtcheckout.Text
Cells(currentrow, 9) = Cbopaymenttype.Text
Cells(currentrow, 10) = Txttotalpayment.Text
Cells(currentrow, 11) = cmbouser.Text
End If
End Sub

Something like this should work (untested). The matched row is stored in a global variable so you can update it when you're finished editing
Dim CurrentRow As Range 'to store the matched row
Private Sub btsearch_Click()
Dim totrows As Long, i As Long, fName
fName = Trim(Txtforename.Text)
If Len(fName) = 0 Then
MsgBox "Please enter guest name!!"
Exit Sub
End If
totrows = Report.Range("A1").CurrentRegion.Rows.Count
Set CurrentRow = Nothing 'clear any previous row
For i = 2 To totrows
If Trim(Report.Cells(i, 1)) = fName Then
Set CurrentRow = Report.Rows(i)
LoadRow CurrentRow '<< save the matched row
Exit For
End If
Next i
If CurrentRow Is Nothing Then
MsgBox "not found!"
End If
End Sub
Private Sub btnupdate_Click()
If MsgBox("Would you like to update guest details?", _
vbYesNo + vbQuestion, "Update Record") = vbYes Then
SaveRow CurrentRow
End If
End Sub
'load a row of data into the userform
Sub LoadRow(rw As Range)
With rw
Txtforename.Text = .Cells(1).Value
Txtsurename.Text = .Cells(2).Value
Cboidtype.Text = .Cells(3).Value
'etc etc
End With
End Sub
'save the userform data back to the sheet
Sub SaveRow(rw As Range)
With rw
.Cells(1).Value = Txtforename.Text
.Cells(2).Value = Txtsurename.Text
.Cells(3).Value = Cboidtype.Text
'etc etc
End With
End Sub

First thing I would check is the result value of the MsgBox. MsgBox always returns an integer, and answer is a variant.
Secondly I would declare answer as an integer. Together it could become this : . . .
Dim answer As Integer
answer = Msgbox("Would you ... ecord")
Debug.Print "' answer := " & answer ' display result in immediate-window
MsgBox "' answer := " & answer ' or display the result with a msgbox
If answer = vbYes Then
Debug.Print "' then"
' while you are busy debugging, display this value too
Debug.Print "' currentrow := " & currentrow
. . .
Else
Debug.Print "' else"
End If
. . .

Related

How do I split the output of an excel report when collecting input with a user form and exporting to PDF?

I am trying to create a front-end form that can be filled out by a user, which will then populate a back-end spreadsheet the user cannot edit. This spreadsheet needs to follow a standard layout that I have already created, and the form will populate predetermined cells (or will create cells following the layout) based on user input from the form. I also need the form to be able to add/repeat questions, as well as duplicate sections in the spreadsheet based on user input requirements ("Do you need to add a section? [Yes/No]" //If [Yes], then duplicate section, repeat questions in form; if [No], then export data to spreadsheet, exit form). The spreadsheet layout consists of sections. The number of sections/cells per section required will vary from user to user, but the type of data will typically remain the same, and therefore should be able to choose the name of the field from a list of some sort (drop down?) However, the user may need to create a custom name for a field. I also need the form to be able to automatically adjust cell sizes based on the amount of text for that value. It is important that this form is printable, and does not separate sections from page to page. Furthermore, each "Notes" field will vary in size, and should be automatically resized to only show the existing text, plus one blank line for hand-written notes. I would also like the form to prompt the user to indicate whether a field is needed (some fields will be permanent, and the user will not be prompted about these fields). If the field is not needed, I need the form to exclude it from the final output.
I am open to suggestions on how to design this project differently than I have already (for example, using alternate programs/software/coding languages).
So far, however, I have created a user form in Excel that collects data and inputs it into a spreadsheet, which can then be exported to a PDF report using a set format/layout on another sheet of the workbook. The layout consists of a "Header" section and an "Item" section. In the form, the user can input a single job number and multiple item numbers, and when they export the report, the code prints the job number in the provided layout for the header, and then loops through the item numbers and copies and populates the item section for as many items as the user has provided. In the exported PDF, however, the item section gets split between pages, regardless of page orientation (landscape orientation is preferred). How do I prevent the "Item" section from being broken up between pages?
Option Explicit
Dim ctl As Control
Dim rCell As Range
Dim img As Picture
Dim newrow As ListRow
Dim tbl1 As ListObject
Dim msgValue As VbMsgBoxResult
Dim ary As Variant, aryx As Variant
Dim ws2 As Worksheet, ws1 As Worksheet
Dim s As String, FilePath As String, user As String, pFilename As String, part As String
Dim x As Long, sc As Long, j As Long, ctr As Long, rctr As Long, tbl1row As Long, r As Long, t As Long, items As Long, y As Long, ctrx As Long
Private Sub cmdCLEAR_Click()
MsgBox ("This action only clears the form NOT the record" & vbCrLf & "Ready for adding NEW entry."), vbOKOnly, "Clear Form "
CLEARFORM
Me.cmdADD.Enabled = True
Me.TextBox6.SetFocus
End Sub
Sub CLEARFORM()
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ComboBox"
ctl.ListIndex = -1
ctl.Value = ""
End Select
Next ctl
Me.Image1.Picture = LoadPicture("") '*********clears picture******
End Sub
Private Sub cmdADD_Click()
For x = 1 To 35
If Controls("TextBox" & x).Text = "" Then
MsgBox "Data field missing", vbCritical, "Data missing"
Exit Sub
End If
Next x
msgValue = MsgBox("Do want to add another item?", vbYesNo + vbQuestion, "Next Item ?")
If msgValue = vbYes Then
SAVEDATANEXT
For x = 16 To 35
Me.Controls("TextBox" & x).Text = ""
Next x
Me.TextBox6.SetFocus
Exit Sub
End If
SAVEDATA
LOADLIST
LOADCOMBO1
End Sub
Sub SAVEDATANEXT()
Set newrow = tbl1.ListRows.Add
With newrow
For x = 1 To 35
.Range(x) = Me.Controls("TextBox" & x).Text '***************textbox35 contains picture filepath ***********
Next x
.Range(36) = tbl1.ListRows.Count '*********this is important row counter saves the need for search routines***********
End With
End Sub
Sub SAVEDATA()
Set newrow = tbl1.ListRows.Add
With newrow
For x = 1 To 35
.Range(x) = Me.Controls("TextBox" & x).Text '***************textbox35 contains picture filepath ***********
Next x
.Range(36) = tbl1.ListRows.Count '*********this is important row counter saves the need for search routines***********
End With
CLEARFORM
LOADLIST
End Sub
Sub LOADLIST()
Set ws2 = Sheet2
Set tbl1 = ws2.ListObjects("Table1")
With tbl1
If .DataBodyRange.Cells(1, 1) = vbNullString Then Exit Sub
ary = .DataBodyRange
End With
Me.ListBox1.List = ary
End Sub
Private Sub cmdPRINT_Click()
If Me.ComboBox1.Value = vbNullString Then
MsgBox "A PDF cannot be created because no Part # selected.", , "No Part# selected."
Exit Sub
End If
With Sheet3
.Range("A28:O10000").Clear
.Range("D2:D10").Value = ""
.Range("J2:J8").Value = ""
.Range("B17:N17").Value = ""
.Range("B19:N19").Value = ""
.Range("B21:N21").Value = ""
.Range("D23").Value = ""
For Each img In Sheet3.Pictures: img.Delete: Next img '**********clears pictures prior to building new PDF********
ctr = 28
For x = 1 To items - 2
.Range("A15:O26").Copy .Range("A" & ctr)
ctr = ctr + 13
Next x
For y = 2 To 8
.Range("D" & y).Value = Me.ListBox1.List(0, y - 2)
.Range("J" & y).Value = Me.ListBox1.List(0, y - 2 + 7)
.Range("D10").Value = Me.ListBox1.List(0, 14)
Next y
ctr = 0
ctrx = 0
For x = 1 To items - 1
.Cells(17 + ctr, 2).Value = Me.ListBox1.List(ctrx, 15)
.Cells(17 + ctr, 4).Value = Me.ListBox1.List(ctrx, 16)
.Cells(17 + ctr, 6).Value = Me.ListBox1.List(ctrx, 17)
.Cells(17 + ctr, 8).Value = Me.ListBox1.List(ctrx, 18)
.Cells(17 + ctr, 10).Value = Me.ListBox1.List(ctrx, 19)
.Cells(17 + ctr, 12).Value = Me.ListBox1.List(ctrx, 20)
.Cells(17 + ctr, 14).Value = Me.ListBox1.List(ctrx, 21)
.Cells(19 + ctr, 2).Value = Me.ListBox1.List(ctrx, 22)
.Cells(19 + ctr, 4).Value = Me.ListBox1.List(ctrx, 23)
.Cells(19 + ctr, 6).Value = Me.ListBox1.List(ctrx, 24)
.Cells(19 + ctr, 8).Value = Me.ListBox1.List(ctrx, 25)
.Cells(19 + ctr, 10).Value = Me.ListBox1.List(ctrx, 26)
.Cells(19 + ctr, 12).Value = Me.ListBox1.List(ctrx, 27)
.Cells(21 + ctr, 2).Value = Me.ListBox1.List(ctrx, 28)
.Cells(21 + ctr, 6).Value = Me.ListBox1.List(ctrx, 29)
.Cells(21 + ctr, 8).Value = Me.ListBox1.List(ctrx, 30)
.Cells(21 + ctr, 12).Value = Me.ListBox1.List(ctrx, 31)
.Cells(21 + ctr, 14).Value = Me.ListBox1.List(ctrx, 32)
.Cells(23 + ctr, 4).Value = Me.ListBox1.List(ctrx, 33)
'**************************************inserting picture into PDF loader*****************
pFilename = Me.ListBox1.List(ctrx, 34)
If pFilename = "" Then GoTo Err:
Set img = .Pictures.Insert(pFilename)
With img
.Left = Sheet3.Cells(23 + ctr, 14).Left
.Top = Sheet3.Cells(23 + ctr, 14).Top
.Width = 16
.Height = 44.25
.Placement = 1
.PrintObject = True
End With
Err:
'***************************************************************************************
ctrx = ctrx + 1
ctr = ctr + 13
Next x
End With
user = Environ("Username")
FilePath = "C:\Users\" & user & "\Desktop\"
ThisWorkbook.Worksheets("Sheet3").Select
part = Sheet3.Cells(2, 4)
Application.ScreenUpdating = True
'*****************set print area and orientaton********************
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.PrintArea = Sheet3.Range(Sheet3.Cells(1, 1), Sheet3.Cells(ctr, 15))
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
INSERTBREAK
End With
Application.PrintCommunication = True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath & "\Part# " & part, OpenAfterPublish:=False, IgnorePrintAreas:=False
'*********************************************************************
Application.ScreenUpdating = True
MsgBox "Data has been exported to PDF on Desktop."
With Sheet3
.Range("A28:O10000").Clear
.Range("D2:D10").Value = ""
.Range("J2:J8").Value = ""
.Range("B17:N17").Value = ""
.Range("B19:N19").Value = ""
.Range("B21:N21").Value = ""
.Range("D23").Value = ""
For Each img In Sheet3.Pictures: img.Delete: Next img '**********clears pictures ready to build new PDF********
End With
End Sub
'********************************open file dialog box to get picture location******************
Private Sub cmdGETPHOTO_Click()
On Error Resume Next
pFilename = Application.GetOpenFilename(FileFilter:="Jpg Files (*.jpg), *.jpg", Title:="SELECT TOOL PHOTO")
Me.Image1.Picture = LoadPicture(pFilename)
Me.TextBox35.Text = pFilename
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub Frame2_Click()
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Me.ListBox1.ListIndex = -1 Then Exit Sub
If Me.ListBox1.ListIndex > -1 Then sc = Me.ListBox1.ListIndex
With Me.ListBox1
For x = 1 To 35
Me.Controls("TextBox" & x).Value = .List(sc, x - 1)
Next x
tbl1row = .List(sc, 35)
End With
On Error GoTo Err
Me.Image1.Picture = LoadPicture(Me.TextBox35.Text) 'retrieves picture file location************
Exit Sub
Err: Me.Image1.Picture = LoadPicture("")
End Sub
Private Sub cmdDELETE_Click()
If Me.ListBox1.ListIndex < 0 Then
MsgBox "No Record selected", , "Errors"
Exit Sub
End If
msgValue = MsgBox("ARE YOU CERTAIN YOU WISH TO REMOVE RECORD?", vbCritical + vbYesNo + vbDefaultButton2, "Remove Record")
If msgValue = vbNo Then
CLEARFORM
Exit Sub
End If
tbl1.ListRows(tbl1row).Delete
CLEARFORM
LOADLIST
LOADCOMBO1
MsgBox ("RECORD REMOVED"), vbOKOnly + vbInformation, "Record Removed"
End Sub
Private Sub cmdUPDATE_Click()
If Me.ListBox1.ListIndex < 0 Then
MsgBox "No Record selected", , "Errors"
Exit Sub
End If
With tbl1
For x = 1 To 35
.Range(tbl1row + 1, x) = Me.Controls("TextBox" & x).Text '*********textbox35 contains picture filepath **********
Next x
End With
CLEARFORM
LOADLIST
LOADCOMBO1
End Sub
Private Sub ComboBox1_Change()
With tbl1
r = .ListRows.Count
For t = r To 1 Step -1
.DataBodyRange.Cells(t, 36) = t '******loads range with rowctr prior to spliting with 'FILTER' ***********
Next t
End With
FILTER
items = Me.ListBox1.ListCount
End Sub
Sub FILTER()
ary = tbl1.DataBodyRange
rctr = 1
For j = 1 To UBound(ary)
If ary(j, 1) = Me.ComboBox1.Text Then
rctr = rctr + 1
End If
Next j
ReDim aryx(1 To rctr, 1 To 36)
ctr = 1
For j = 1 To UBound(ary)
If ary(j, 1) = Me.ComboBox1.Text Then
For x = 1 To 36
aryx(ctr, x) = ary(j, x)
Next x
ctr = ctr + 1
End If
Next j
Me.ListBox1.List = aryx
End Sub
Sub LOADCOMBO1()
Set ws2 = Sheet2
Set tbl1 = ws2.ListObjects("Table1")
With tbl1
If .DataBodyRange.Cells(1, 1) = vbNullString Then Exit Sub
ary = .DataBodyRange
End With
Me.ComboBox1.Clear
With CreateObject("Scripting.Dictionary")
For Each rCell In tbl1.ListColumns(1).DataBodyRange
If Not .Exists(rCell.Value) And rCell.Value <> vbNullString Then .Add rCell.Value, Nothing
Next rCell
Me.ComboBox1.List = .keys
.RemoveAll
End With
End Sub
Private Sub UserForm_Initialize()
Set ws2 = Sheet2
Set tbl1 = ws2.ListObjects("Table1")
Me.ListBox1.ColumnCount = 36
s = ""
For x = 1 To 36
s = s & 50 & ";"
Next x
Me.ListBox1.ColumnWidths = s
For x = 1 To 35
Me.Controls("Label" & x).Caption = tbl1.HeaderRowRange(x)
Next x
Me.cmdADD.Enabled = True
Me.TextBox35.Enabled = False
LOADLIST
LOADCOMBO1
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'************ensures workbook is saved if accidently closed**************
If CloseMode = vbFormControlMenu Then
Cancel = False
ThisWorkbook.Save
Unload Me
End If
End Sub
I have tried using various forms of the PageBreak method. I have also tried setting the page layout in various ways, but nothing has worked. I even tried grouping the cells in the "Item" section. I am at a total loss.

Can I use VBA to update a dataset?

I'm using a vba UserForm to enter in "Vehicle Reg" and choose "Current Status" from a combobox, which currently adds this data to a new line along with a uniqueID, the username, and the time.
I'd like to create a finite list of Vehicle Reg, and use the UserForm to update the Current Status (1 column to the right) with the new value.
Is there a way I can alter what I have to make this work? I am brand new to vba and have been googling for days!
I have a Submit Button, a Reset Button, and on the main spreadsheet I have a macro button that I have attached the "Show Form".
Here's what I have:
Sub Reset()
Dim iRow As Long
iRow = [Counta(Database!A:A)] 'identifying the last row
With frmForm
.txtID.Value = ""
.cmbStatus.Clear
.cmbStatus.AddItem "Loaded - In"
.cmbStatus.AddItem "Loaded - Out"
.cmbStatus.AddItem "Empty - Parked"
.cmbStatus.AddItem "Empty - On Bay"
.lstDatabase.ColumnCount = 4
.lstDatabase.ColumnHeads = True
If iRow > 1 Then
.lstDatabase.RowSource = "Database!A2:C" & iRow
Else
.lstDatabase.RowSource = "Database!A2:C2"
End If
End With
End Sub
Sub Submit()
Dim sh As Worksheet
Dim iRow As Long
Set sh = ThisWorkbook.Sheets("Database")
iRow = [Counta(Database!A:A)] + 1
With sh
.Cells(iRow, 1) = iRow - 1
.Cells(iRow, 2) = frmForm.txtID.Value
.Cells(iRow, 3) = frmForm.cmbStatus.Value
.Cells(iRow, 4) = Application.UserName
.Cells(iRow, 5) = [Text(Now(), "DD-MM-YYY HH:MM:SS")]
End With
End Sub
Sub Show_Form()
Call Reset
frmForm.Show
End Sub
**And my initialize code:**
Private Sub UserForm_Initialize()
With frmForm
Height = 370
Width = 645
End With
End Sub
Private Sub cmdReset_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to reset the form?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
Call Reset
End Sub
Private Sub cmdSave_Click()
With Me
If txtID.Value = "" Then
MsgBox "Reg Cannot Be Blank", vbOKOnly + vbCritical + vbDefaultButton1, "Reg Blank"
End If
Exit Sub
End With
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to save?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
Call Submit
Call Reset
Unload Me
End Sub
Private Sub frmForm_Initialize()
Call Reset
End Sub
Thanks!
Use the lstDatabase_Click() event together with the .ListIndex property to load the form items from the sheet. The Reset de-selects the line. Save without a line selected adds a new record, with line selected updates the existing record.
Option Explicit
Sub Show_Form()
frmForm.Show
End Sub
Private Sub cmdReset_Click()
' unselect line lstdatabase
With Me
.txtID.Value = ""
.cmbStatus = ""
.lstDatabase.ListIndex = -1
End With
End Sub
Private Sub UserForm_Initialize()
With Me
.Height = 370
.Width = 645
.txtID.Value = ""
.cmbStatus.Clear
.cmbStatus.AddItem "Loaded - In"
.cmbStatus.AddItem "Loaded - Out"
.cmbStatus.AddItem "Empty - Parked"
.cmbStatus.AddItem "Empty - On Bay"
.lstDatabase.ColumnCount = 4
.lstDatabase.ColumnHeads = True
End With
LoadDatabase
End Sub
Private Sub cmdSave_Click()
If txtID.Value = "" Then
MsgBox "Reg Cannot Be Blank", vbCritical, "Reg Blank"
ElseIf cmbStatus.Value = "" Then
MsgBox "Status Cannot Be Blank", vbCritical, "Status Blank"
ElseIf MsgBox("Do you want to save?", vbYesNo, "Confirmation") = vbYes Then
Call Submit
'Unload Me
End If
End Sub
Sub Submit()
Dim i As Long, r As Long
With lstDatabase
i = .ListIndex
' is line selected
If i >= 0 Then r = .List(i, 0) + 1
End With
' update or add
With Sheets("Database")
' add new find last line
If r = 0 Then
r = 1 + .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(r, 1) = r - 1
.Cells(r, 2) = frmForm.txtID.Value
End If
' update
.Cells(r, 3) = frmForm.cmbStatus.Value
.Cells(r, 4) = Application.UserName
.Cells(r, 5) = [Text(Now(), "DD-MM-YYY HH:MM:SS")]
End With
End Sub
Private Sub lstDatabase_Click()
Dim i As Long, r As Long
With lstDatabase
i = .ListIndex
If i >= 0 Then
txtID.Value = .List(i, 1)
cmbStatus.Text = .List(i, 2)
End If
End With
End Sub
Sub LoadDatabase()
Dim iRow As Long
With Sheets("Database")
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
If iRow < 2 Then iRow = 2
lstDatabase.RowSource = "Database!A2:C" & iRow
End Sub

How to connect a list box (MULTI SELECT) on form to connect/display to another sheet in workbook?

I am trying to create a form:
where you are able to select multiple items and it display in excel sheet
I was able to do so for selecting only one item in a list, but when changed to multi select I don't know how to link the form and the worksheet together.
Also - how do I make it display in the "database" portion of my form here:
code for Module 1
Option Explicit
Sub Reset()
Dim iRow As Long
iRow = [Counta(Database!A:A)] ' identifying the last row
With frmForm
.txtName.Value = ""
.txtAge.Value = "'"
.lstInvited.Clear
.lstInvited.AddItem "Aya"
.lstInvited.AddItem "Bi"
.lstInvited.AddItem "Britt"
.lstInvited.AddItem "Cami"
.lstInvited.AddItem "Sarl"
.lstInvited.AddItem "Ch"
.cmbTeacher.Clear
.cmbTeacher.AddItem "A"
.cmbTeacher.AddItem "Bia"
.cmbTeacher.AddItem "Cami"
.cmbTeacher.AddItem "China"
.cmbStudy.Clear
.cmbStudy.AddItem "1"
.cmbStudy.AddItem "2"
.cmbStudy.AddItem "3"
.cmbStudy.AddItem "45"
.lstAction.Clear
.lstAction.AddItem "Wants to study again"
.lstAction.AddItem "Other, Please specify in Notes"
.lstInfo.Clear
.lstInfo.AddItem "Open-minded"
.lstInfo.AddItem "Needs to study in a different language"
.lstInfo.AddItem "Other, Please specify in Notes"
.lstZoom.Clear
.lstZoom.AddItem "Attentive"
.lstZoom.AddItem "Not interactive/ Not connected"
.lstZoom.AddItem "Occupied"
.lstZoom.AddItem "Other, Please specify in Notes"
.txtNotes.Value = ""
.lstDatabase.ColumnCount = 10
.lstDatabase.ColumnHeads = True
If iRow > 1 Then
.lstDatabase.RowSource = "Database!A2:J" & iRow
Else
.lstDatabase.RowSource = "Database!A2:J2"
End If
End With
End Sub
Sub Submit()
Dim sh As Worksheet
Dim iRow As Long
Set sh = ThisWorkbook.Sheets("Database")
iRow = [Counta(Database!A:A)] + 1
With sh
.Cells(iRow, 1) = frmForm.txtName.Value
.Cells(iRow, 2) = frmForm.lstInvited.Value
.Cells(iRow, 3) = frmForm.txtAge.Value
.Cells(iRow, 4) = frmForm.cmbTeacher.Value
.Cells(iRow, 5) = frmForm.cmbStudy.Value
.Cells(iRow, 6) = frmForm.dtpDate.Value
.Cells(iRow, 7) = frmForm.lstAction.Value
.Cells(iRow, 8) = frmForm.lstInfo.Value
.Cells(iRow, 9) = frmForm.lstZoom.Value
.Cells(iRow, 10) = frmForm.txtNotes.Value
End With
End Sub
Sub Show_Form()
frmForm.Show
End Sub
`
and then here is the code for form (frmForm)
Private Sub cmdReset_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox(" Do you want to reset the form?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
Call Reset
End Sub
Private Sub cmdSave_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox(" Do you want to save the data?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
Call Submit
Call Reset
End Sub
Private Sub lstInvited_Initialize()
Me.lstInvited.RowSource = strInvitedList
End Sub
Private Sub lstAction_Initialize()
Me.lstAction.RowSource = strDVActionList
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub lstAction_Click()
For i = 0 To lstAction.ListCount - 1
If lstAction.Selected(i) = True Then
ListBox2.AddItem
ListBox2.Column(0, (ListBox2.ListCount - 1)) = ListBox1.Column(0, i)
ListBox2.Column(1, (ListBox2.ListCount - 1)) = ListBox1.Column(1, i)
ListBox2.Column(2, (ListBox2.ListCount - 1)) = ListBox1.Column(2, i)
End If
Next
End Sub
Private Sub UserForm_Initialize()
Call Reset
End Sub
You'll need to loop through the list box. You can use the .ListCount property to get the number of rows (the index starts at 0 so use .ListCount - 1). You can check if the index is selected by using .Selected(i) where i is the loop counter.
So if your listbox is called ListBox1 you can do something like this to determine what rows are selected:
For i = 0 to ListBox1.Count - 1
If ListBox1.Selected(i) = True Then Debug.Print "Index " & i & " is selected"
Next i
Instead of the debug message you can add the information to your worksheet by using the listbox .List method, you'll need to use i for the row parameter and whatever number you need for the column parameter.
To add the information to the form you can use the .List method again to set those properties.
You may also want to look into assigning the values to an array as this would shorten your code.

User form (Updating,Adding, Deleting and Resetting)

Hi Im having a problem on Updating and Deleting the data on my Worksheet. Using VBA Excel user form I always got a problem on Application defined object defined error.
I tried Rows select method but I cant get the output that I needed.
Private Sub cmdUpdate_Click()
If Me.cmbAssetTag.Value = "" Then
MsgBox "Asset Tag Can Not be Blank!!!", vbExclamation, "Asset Tag"
Exit Sub
End If
AssetTag = Me.cmbAssetTag.Value
Sheets("Assets").Select
Dim r As Single
Dim msg As String
Dim ans As String
r = Me.cmbAssetTag.Value
Rows(r, Cells).Select
Cells(r, 2) = Me.txtName.Text
Cells(r, 3) = Me.txtManager.Text
Cells(r, 4) = Me.txtDepartment.Text
Cells(r, 5) = Me.txtAction.Text
Cells(r, 6) = Me.txtTemplate.Text
Cells(r, 7) = Me.txtModel.Text
Cells(r, 8) = Me.txtReason.Text
Cells(r, 9) = Me.txtDate.Text
Cells(r, 10) = Me.txtUpdatedBy.Text
msg = "Asset Tag" & rowselect & " Successfully Updated...Continue?"
Unload Me
ans = MsgBox(msg, vbYesNo, "Update")
If ans = vbYes Then
UserForm1.Show
Else
Sheets("Assets").Select
End If
End Sub
The actual result should replaced the data on the sheet with the replaced input

VBA User from Text boxes not populating from worksheet

I have a list box which details inquiries and when the double click is used on a line in the list box, a second userform opens to allow the information to update, the issues i am having is the date which is supposed to come from the 13 & 14th columns is not transferring back to the text box:
.Offset(0, 13).Value, txtnotes.Value, _
.Offset(0, 14).Value, txtdtime.Value)
The other combo boxes and text boxes are taking retrieving the correct data, but it is these final boxes which will not go.
here is the complete code:
Private Sub UserForm_Initialize()
'dim the variables
Dim i As Integer
On Error Resume Next
'find the selected list item
i = frmenqnew.lstenq.ListIndex
'add the values to the text boxes
Me.txtenqup.Value = frmenqnew.lstenq.Column(0, i)
Me.txtcustup.Value = frmenqnew.lstenq.Column(1, i)
Me.cboup3.Value = frmenqnew.lstenq.Column(4, i)
Me.cboup4.Value = frmenqnew.lstenq.Column(5, i)
Me.cboup5.Value = frmenqnew.lstenq.Column(6, i)
Me.cboup6.Value = frmenqnew.lstenq.Column(7, i)
Me.txtrev.Value = frmenqnew.lstenq.Column(9, i)
Me.txtnotes.Value = frmenwnew.lstenq.Column(13, i)
Me.txtdtime.Value = frmenwnew.lstenq.Column(14, i)
With cboup5
.AddItem "Active"
.AddItem "Dormant"
.AddItem "Lost"
.AddItem "Sold"
End With
With cboup6
.AddItem "Drawing"
.AddItem "Appraisal"
.AddItem "Verification"
.AddItem "Presenting"
End With
On Error GoTo 0
End Sub
Private Sub cmdUpdate_Click()
' To write edited info of userform2 to Sheets("Data")
Dim LastRow As Long
Dim ABnum As Double
Dim ABrng As Range
Dim WriteRow As Long
'error statement
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
' Make sure we're on the right sheet
With Sheets("Data")
' Get the last row used so can set up the search range
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' Set the range to search for the AB number
Set ABrng = .Range("A1:A" & LastRow)
' Get the AB number from what is selected on userform2
ABnum = txtenqup.Value
' Get the row of sheet for this AB number
WriteRow = Application.Match(ABnum, ABrng, 0)
' Make this AB number the active cell
With .Cells(WriteRow, 1)
'Check for changes
If Not hasValuePairsChanges(.Offset(0, 4).Value, cboup3.Value, _
.Offset(0, 5).Value, cboup4.Value, _
.Offset(0, 6).Value, cboup5.Value, _
.Offset(0, 7).Value, cboup6.Value, _
CDate(.Offset(0, 8).Value), Date, _
CDbl(.Offset(0, 9).Value), CDbl(txtrev.Value), _
.Offset(0, 13).Value, txtnotes.Value, _
.Offset(0, 14).Value, txtdtime.Value) Then
MsgBox "No Change in Data", vbInformation, ""
Exit Sub
End If
' Write in all the editable options
.Offset(0, 4) = cboup3.Value
.Offset(0, 5) = cboup4.Value
.Offset(0, 6) = cboup5.Value
.Offset(0, 7) = cboup6.Value
.Offset(0, 8) = Date
.Offset(0, 9) = txtrev.Value
.Offset(0, 13) = txtnotes.Value
.Offset(0, 14) = txtdtime.Value
Sheets("Archive").Range("A" & Rows.Count).End(xlUp)(2).Resize(, 14).Value = .Resize(, 14).Value
End With
End With
' Filter the Data
FilterMe
' Close the form
Unload Me
MsgBox ("Enquiry E0" + Me.txtenqup.Text + " has been updated")
errHandler:
'Protect all sheets if error occurs
'Protect_All
'show error information in a messagebox
If Err.Number <> 0 Then
MsgBox "Error " & Err.Number & " just occured."
End If
End Sub
Function hasValuePairsChanges(ParamArray Args() As Variant) As Boolean
Dim n As Long
For n = 0 To UBound(Args) Step 2
If Not Args(n) = Args(n + 1) Then
hasValuePairsChanges = True
Exit Function
End If
Next
End Function
Any help much appreciated
Thanks

Resources