Related
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.
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
. . .
I'm very new to Excel VBA and I have found solutions to most my problem through Stackoverflow.com But still, there is a problem I've couldn't solve.
I am working on a multidimensional Userform to maintain our database. The Userform I'm working on containing option boxes, checkboxes, textboxes and combo boxes.
After long search and work, I fixed the search bottoms and they all are working. But I can not get the Update bottom and the Delete bottom to work.
I have uploaded the file, I would be grateful if anyone can help me out with this issue.
Private Sub bt2_Click() 'Update shipment
Dim sonsat As Long, sor As String
If ListBox1.ListIndex = -1 Then
MsgBox "Choose an item", vbExclamation, ""
Exit Sub
End If
sor = MsgBox("Are your sure?", vbYesNo, "")
If sor = vbNo Then Exit Sub
lastrow = Sheets("logbook").Cells(Rows.count, 1).End(xlUp).Row
Sheets("logbook").Range("A1:A" & lastrow).Find(What:=ListBox1.Value,
LookIn:=xlValues, LookAt:=xlWhole).Activate
sonsat = ActiveCell.Row
Cells(sonsat, 1) = op1
Cells(sonsat, 2) = op2
Cells(sonsat, 3) = chb1
Cells(sonsat, 4) = chb2
Cells(sonsat, 5) = tb14
Cells(sonsat, 6) = tb1
Cells(sonsat, 7) = tb2
Cells(sonsat, 8) = tb3
Cells(sonsat, 9) = tb4
Cells(sonsat, 10) = tb5
Cells(sonsat, 11) = cb1
Cells(sonsat, 12) = tb6
Cells(sonsat, 13) = tb7
Cells(sonsat, 14) = tb8
Cells(sonsat, 15) = tb9
Cells(sonsat, 16) = cb2
Cells(sonsat, 17) = tb10
Cells(sonsat, 18) = tb11
Cells(sonsat, 19) = tb12
Cells(sonsat, 20) = cb3
Cells(sonsat, 21) = cb4
Cells(sonsat, 22) = tb13
MsgBox "Item Has Been Changed", vbInformation, ""
ListBox1.list = Sheets("logbook").Range("A1:V" &
Sheets("logbook").Cells(Rows.count, 1).End(xlUp).Row).Value
If Me.op1.Value = True Then
Cells(sonsat, 1).Value = "X"
Else
Cells(sonsat, 1).Value = "-"
End If
If Me.op2.Value = True Then
Cells(sonsat, 2).Value = "X"
Else
Cells(sonsat, 2).Value = "-"
End If
If Me.chb1.Value = True Then
Cells(sonsat, 3).Value = "X"
Else
Cells(sonsat, 3).Value = "-"
End If
If Me.chb2.Value = True Then
Cells(sonsat, 4) = "X"
Else
Cells(sonsat, 4) = "-"
End If
End Sub
Private Sub bt3_Click() 'delete shipmet
Dim sil As Long
Dim e, b, c, d As Integer
If ListBox1.ListIndex = -1 Then
MsgBox "Choose an entry", vbExclamation, ""
Exit Sub
End If
If ListBox1.ListIndex >= 0 Then
cevap = MsgBox("Entry will be deleted. ... Are you sure ?", vbYesNo, "")
If cevap = vbYes Then
Sheets("logbook").Range("A:A").Find(What:=ListBox1.Value).Activate
sil = ActiveCell.Row
Sheets("logbook").Rows(sil).Delete
End If
End If
For d = 1 To 2
Controls("op" & d) = False
Next
For c = 1 To 4
Controls("cb" & c) = "-"
Next
For b = 1 To 2
Controls("chb" & b) = False
Next
For e = 1 To 14
Controls("tb" & e) = ""
Next
ListBox1.list = Sheets("logbook").Range("A1:V" &
Sheets("logbook").Cells(Rows.count, 1).End(xlUp).Row).Value
End Sub
The following is based on the file you uploaded to Google Drive (as at 2017-06-08, 09:01 UK Time).
I lost a few controls when trying to open the workbook, perhaps our versions of Excel are too different for mine to cope with them. These were your date controls dtp2 and dtp3. I commented out code relating to these whenever they caused me trouble. Hopefully that doesn't negatively affect what follows ...
Main Suggestions
To get things to run at all I had to declare the lastrow variable and the cevap variable.
Your listbox1 is allowing multi-select. If you want to update just one row, you need to ensure that only one row is selected. Within the "Behaviour" section of the control properties, I'd change MultiSelect to 0 - fmMultiSelectSingle.
Because you were allowing multi-select, listbox1.value wasn't working. You have to do it differently when you allow multi-select (see here). But assuming you're okay with single-select, you don't need to worry about that.
When you use your Find ... Activate you'll then get a different error. Excel can't Activate the spreadsheet because Userform1 retains focus. You might be able to change that by making the form "non-modal", but I wouldn't. Instead, rather than, for example:
Sheets("logbook").Range("A1:A" & lastrow).Find(What:=ListBox1.Value, _
LookIn:=xlValues, LookAt:=xlWhole).Activate
sonsat = ActiveCell.Row
I'd do
sonsat = Sheets("logbook").Range("A1:A" &
lastrow).Find(What:=ListBox1.Value, _
LookIn:=xlValues, LookAt:=xlWhole).Row
Which avoid's the need to Activate. After that the code should run without complaining.
However, it still doesn't do what you want. The value of the listbox is based on your bound column, which you've set to the be first column. That value doesn't uniquely identify the row. As a result, when you run the update/delete the code updates/deletes the first matching row.
Minor Matters
There is currently nothing preventing the user selecting and updating/deleting the header row. Personally, I'd take them out of the listbox (start at A2 instead of A1) and add them as "column headings" in the form.
I'm guessing the title of the form should be "Data Entry Application" not "Data Entery Application".
I am new to coding and have got this far by googling. I am hoping it is a fairly simple change in the code. I have a form which shows what I want it to. My close button works however my 'add data' button doesn't work. As in it isn't populating the information I enter into the completed form to the worksheet in excel. I get the first column populating always with 0.1, no matter what I enter in. Here is my code if anyone would like to assist. I would be very grateful.
Private Sub cmdbutton_add_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Inputs")
'find first empty row in database
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'Check for a Name number
If Trim(Me.textbox_lineno.Value) = " " Then
Me.textbox_lineno.SetFocus
MsgBox "Please Complete the form"
Exit Sub
End If
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.textbox_lineno.Value
ws.Cells(iRow, 1).Value = Me.listbox_pipetype.Value
ws.Cells(iRow, 1).Value = Me.textbox_frompit.Value
ws.Cells(iRow, 1).Value = Me.textbox_topitormh.Value
ws.Cells(iRow, 1).Value = Me.textbox_linealm.Value
ws.Cells(iRow, 1).Value = Me.textbox_depthstart.Value
ws.Cells(iRow, 1).Value = Me.textbox_depthend.Value
ws.Cells(iRow, 1).Value = Me.textbox_pipedia.Value
ws.Cells(iRow, 1).Value = Me.textbox_beddingbelow.Value
ws.Cells(iRow, 1).Value = Me.textbox_beddingabove.Value
ws.Cells(iRow, 1).Value = Me.textbox_roadallowance.Value
MsgBox "Data Added", vbOKOnly + vbInformation, "Data Added"
'Clear the data
Me.textbox_lineno.Value = ""
Me.listbox_pipetype.Value = ""
Me.textbox_frompit.Value = ""
Me.textbox_topitormh.Value = ""
Me.textbox_linealm.Value = ""
Me.textbox_depthstart.Value = ""
Me.textbox_depthend.Value = ""
Me.textbox_pipedia.Value = ""
Me.textbox_beddingbelow.Value = ""
Me.textbox_beddingabove.Value = ""
Me.textbox_roadallowance.Value = ""
Me.textbox_lineno.SetFocus
End Sub
Private Sub cmdbutton_close_Click()
Unload Me
End Sub
This line should never validate:
If Trim(Me.textbox_lineno.Value) = " " Then
You never increment your column assignments. If I know that an Object exists then I will usually opt for a With Object statement over using another variable.
I extracted the code for clearing the textboxes into their own sub routine.
Because all the data is on one row and With .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1) refers the first cell of that row I use Columns(x) which is analogous to using .Cells(1,x). I fell like it looks cleaner.
I feel like these alterations to consolidate the code; make it easier to read. You don't have to scroll up and down the page to see just what the sub is doing.
Private Sub cmdbutton_add_Click()
'Check for a Name number
If Trim(Me.textbox_lineno.Value) = "" Then
Me.textbox_lineno.SetFocus
MsgBox "Please Complete the form", vbInformation, "Action Cancelled"
Exit Sub
End If
With Worksheets("Inputs")
With .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1)
'copy the data to the database
.Columns(1).Value = Me.textbox_lineno.Value
.Columns(2).Value = Me.listbox_pipetype.Value
.Columns(3).Value = Me.textbox_frompit.Value
.Columns(4).Value = Me.textbox_topitormh.Value
.Columns(5).Value = Me.textbox_linealm.Value
.Columns(6).Value = Me.textbox_depthstart.Value
.Columns(7).Value = Me.textbox_depthend.Value
.Columns(8).Value = Me.textbox_pipedia.Value
.Columns(9).Value = Me.textbox_beddingbelow.Value
.Columns(10).Value = Me.textbox_beddingabove.Value
.Columns(11).Value = Me.textbox_roadallowance.Value
End With
End With
MsgBox "Data Added", vbOKOnly + vbInformation, "Data Added"
ClearForm
Me.textbox_lineno.SetFocus
End Sub
Function ClearForm()
'Clear the data
Me.textbox_lineno.Value = ""
Me.listbox_pipetype.Value = ""
Me.textbox_frompit.Value = ""
Me.textbox_topitormh.Value = ""
Me.textbox_linealm.Value = ""
Me.textbox_depthstart.Value = ""
Me.textbox_depthend.Value = ""
Me.textbox_pipedia.Value = ""
Me.textbox_beddingbelow.Value = ""
Me.textbox_beddingabove.Value = ""
Me.textbox_roadallowance.Value = ""
End Function
im using vbs in excel 2010 and i have a form that adds data to this spreadsheet...that's all fine but i need to be able to check if im not duplicating data.
there is one column in spreadsheet where all numbers should be unique.
I'd like to check the text box value in the form against the column entries before i add the value .
this is all i need and this mini project of mine is done
this is the current coding i have that adds the data to sheet
Private Sub cmdbtnSave_Click()
Dim vNewRow As Long
Dim ws As Worksheet
Set ws = DataTable
' Find the next empty row
vNewRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' Check for data in Field 1
If Trim(Me.invoicemonth.Value) = "" Then
Me.invoicemonth.SetFocus
MsgBox "Please enter invoice month!"
Exit Sub
End If
' Check for data in Field 2
If Trim(Me.dfrdate.Value) = "" Then
Me.dfrdate.SetFocus
MsgBox "Please enter DFR date!"
Exit Sub
End If
' Check for data in Field 3
If Trim(Me.actype.Value) = "" Then
Me.actype.SetFocus
MsgBox "Please enter Airfraft Type!"
Exit Sub
End If
' check a/c rego
If Trim(Me.acrego.Value) = "" Then
Me.acrego.SetFocus
MsgBox "Please enter Aircraft Rego!"
Exit Sub
End If
' check client
If Trim(Me.client.Value) = "" Then
Me.client.SetFocus
MsgBox "Please enter Client"
Exit Sub
End If
' check destination
If Trim(Me.dest.Value) = "" Then
Me.dest.SetFocus
MsgBox "Please enter in destination"
Exit Sub
End If
' check dfr hours
If Trim(Me.dfrhrs.Value) = "" Then
Me.dfrhrs.SetFocus
MsgBox "Please enter DFR Hours"
Exit Sub
End If
' check if pilots name is entered
If Trim(Me.Pilots.Value) = "" Then
Me.Pilots.SetFocus
MsgBox "Please input pilot name ya! wwsshhh!"
Exit Sub
End If
'check if tech log hrs is entered
If Trim(Me.txt_tloghrs.Value) = "" Then
Me.txt_tloghrs.SetFocus
MsgBox "wwsshh!! putim tech log hrs ya!"
Exit Sub
End If
'check if tech log number is in
If Trim(Me.txt_tlogno.Value) = "" Then
Me.txt_tlogno.SetFocus
MsgBox "wwsshh!! mi needim numbba blo displa tech log ya!"
Exit Sub
End If
'check if engineer's name is entered
If Trim(Me.cmb_eng.Value) = "" Then
Me.cmb_eng.SetFocus
MsgBox "WWSSHH! NA NEM BLO ENGINEER EM HUSAIT?"
Exit Sub
End If
'check if fuel supplier is put in
If Trim(Me.cmb_fsupply.Value) = "" Then
Me.cmb_fsupply.SetFocus
MsgBox "if no input select/type NULL"
Exit Sub
End If
'check if branch
If Trim(Me.cmb_branch.Value) = "" Then
Me.cmb_branch.SetFocus
MsgBox "if no input select/type NULL"
Exit Sub
End If
'check if tech log number is in
If Trim(Me.txt_finvoice.Value) = "" Then
Me.txt_finvoice.SetFocus
MsgBox "if no input select/type NULL"
Exit Sub
End If
'check fuel liters
If Trim(Me.txt_ltrs.Value) = "" Then
Me.txt_ltrs.SetFocus
MsgBox "if no input select/type NULL"
Exit Sub
End If
' Input the data in the Data Table
ws.Cells(vNewRow, 1).Value = Me.invoicemonth.Value
ws.Cells(vNewRow, 2).Value = Me.dfrdate.Value
ws.Cells(vNewRow, 3).Value = Me.dfrnumber.Value
ws.Cells(vNewRow, 4).Value = Me.actype.Value
ws.Cells(vNewRow, 5).Value = Me.acrego.Value
ws.Cells(vNewRow, 6).Value = Me.client.Value
ws.Cells(vNewRow, 7).Value = Me.dest.Value
ws.Cells(vNewRow, 8).Value = Me.dfrhrs.Value
ws.Cells(vNewRow, 9).Value = Me.Pilots.Value
ws.Cells(vNewRow, 10).Value = Me.txt_tloghrs.Value
ws.Cells(vNewRow, 11).Value = Me.txt_tlogno.Value
ws.Cells(vNewRow, 12).Value = Me.cmb_eng.Value
ws.Cells(vNewRow, 13).Value = Me.cmb_fsupply.Value
ws.Cells(vNewRow, 14).Value = Me.cmb_branch.Value
ws.Cells(vNewRow, 15).Value = Me.txt_finvoice.Value
ws.Cells(vNewRow, 16).Value = Me.cmb_whosupply.Value
ws.Cells(vNewRow, 17).Value = Me.txt_ltrs.Value
ws.Cells(vNewRow, 1).Activate
' Clear all fields and reset the form
Me.invoicemonth.Value = ""
Me.dfrdate.Value = ""
Me.dfrnumber.Value = ""
Me.actype.Value = ""
Me.acrego.Value = ""
Me.client.Value = ""
Me.dest.Value = ""
Me.dfrhrs.Value = ""
Me.Pilots.Value = ""
Me.txt_tloghrs.Value = ""
Me.txt_tlogno.Value = ""
Me.cmb_eng.Value = ""
Me.cmb_fsupply.Value = ""
Me.cmb_branch.Value = ""
Me.txt_finvoice.Value = ""
Me.cmb_whosupply.Value = ""
Me.txt_ltrs.Value = ""
Me.invoicemonth.SetFocus`
Using subroutines, you can perform this more easily than in one big chunk. You would need to set your values for certain variables like "ws" upon UserForm activation.
Your Save Button click event would be just a few lines then, executing each subroutine. First checking for Duplicates, then Checking for Empties, then Copying the Data, Saving the Workbook, and Clearing the Form for another entry. You will still have to use whatever you are doing to navigate the records or take into account which row on which to put the data. I believe in the example you used "VNewRow".
Private Sub cmdbtnSave_Click()
If IsDuplicate() = False Then
Call CheckEmpty
Call SaveData
ActiveWorkbook.Save
Call ClearData
Else
MsgBox("Duplicate records exist for " & txtBoxToCheck.Value & "!")
'Anything else you want to accomplish, such as reset the form
'You can Call ClearData here.
End If
End Sub
Then you would need a subroutine to check for Duplicates on the column that needs to be all unique. In this example, "txtBoxToCheck" is the name of the textbox and it is located on Sheet1 Column "A". When this runs it will return False if there are no duplicates, and True if there are. Then the save event will either save or not based on that.
Function IsDuplicate() As Boolean
Dim lastRow As Long
Dim resultCheck As Boolean
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 'gets last row of Sheet1
For row = 2 to lastRow 'Assuming you have a Header Row and Data begins on row 2.
If txtBoxToCheck.Value = Sheets("Sheet1").Cells(row , 1).Value Then
resultCheck = True
End For
Else
resultCheck = False
End If
Next row 'loop until last row of sheet1
IsDuplicate = resultCheck
End Sub
This would lose your custom message boxes but would save you time. In this example, if you set the Tag property on each control that can't be empty. In the example, they are tagged with "NoEmpty". You could remove your list of If/Then Statements with each having the same code and only one value changes and call this instead.
Private Sub CheckEmpty()
Dim ctl As MSForms.Control
For Each ctl In YourForm.Controls 'Set to your form name
If ctl.Tag = "NoEmpty" Then
If (ctl.Value = "")) Then
MsgBox ("Set value for " & ctl.Name)
ctl.SetFocus
End If
End If
Next ctl
End Sub
That would relieve you of an if statement for each cell checking for blank.
You would have a separate subroutine for SaveData. Taking from your original code, without the "Me."
Private Sub SaveData()
'Input the data in the Data Table
ws.Cells(vNewRow, 1).Value = invoicemonth.Value
ws.Cells(vNewRow, 2).Value = dfrdate.Value
ws.Cells(vNewRow, 3).Value = dfrnumber.Value
ws.Cells(vNewRow, 4).Value = actype.Value
ws.Cells(vNewRow, 5).Value = acrego.Value
ws.Cells(vNewRow, 6).Value = client.Value
ws.Cells(vNewRow, 7).Value = dest.Value
ws.Cells(vNewRow, 8).Value = dfrhrs.Value
ws.Cells(vNewRow, 9).Value = Pilots.Value
ws.Cells(vNewRow, 10).Value = txt_tloghrs.Value
ws.Cells(vNewRow, 11).Value = txt_tlogno.Value
ws.Cells(vNewRow, 12).Value = cmb_eng.Value
ws.Cells(vNewRow, 13).Value = cmb_fsupply.Value
ws.Cells(vNewRow, 14).Value = cmb_branch.Value
ws.Cells(vNewRow, 15).Value = txt_finvoice.Value
ws.Cells(vNewRow, 16).Value = cmb_whosupply.Value
ws.Cells(vNewRow, 17).Value = txt_ltrs.Value
End Sub
And another for ClearData, again using your code from above without the "Me."
Private Sub ClearData()
'Clear all fields and reset the form
invoicemonth.Value = ""
dfrdate.Value = ""
dfrnumber.Value = ""
actype.Value = ""
acrego.Value = ""
client.Value = ""
dest.Value = ""
dfrhrs.Value = ""
Pilots.Value = ""
txt_tloghrs.Value = ""
txt_tlogno.Value = ""
cmb_eng.Value = ""
cmb_fsupply.Value = ""
cmb_branch.Value = ""
txt_finvoice.Value = ""
cmb_whosupply.Value = ""
txt_ltrs.Value = ""
invoicemonth.SetFocus
End Sub
In Summary, by doing it this way, you can more easily adapt your code for future projects that are similar, while making it easier for debugging later by you or other people who might have to work on your code. Keep the navigation and other validation methods in place and just modify where the data comes from and goes, and the specific names of the UserForm Controls, worksheets, etc.
edit: added clarification and more comments to code.