I have a userform to add or remove inventory from a series of tables.
The issue is when the info from the userform is added to ONLY the "Received" table the quantity cell is not acknowledged. It is populated but is not picked up by the table formulas I have in place.
I can got to the table and manually type the quantities in and hit refresh all on the data tab and the quantities update correctly.
I have a pivot table setup on each of these sheets to get the dates of entry, material, and quantity from the "Received" table the product that was entered via the userform shows a zero for the quantity.*
I have tried several converters and format changes but I am still not getting results.
Cdbl, Cint, Cdec, Format(), Changed formats in the Excel Table in question
Private Sub Add_Button_Click()
MsgBox "Are You Sure You Want To Add To Inventory?"
Unload Me
Transaction_Form.Show
Dim the_sheet As Worksheet
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Set the_sheet = Sheets("MATERIALS REC.")
Set table_list_object = the_sheet.ListObjects(1)
Set table_object_row = table_list_object.ListRows.Add
table_object_row.Range(1, 1).Value = CDate(Me.Date_Box)
table_object_row.Range(1, 2).Value = Me.Material_Code_Box
table_object_row.Range(1, 4).Value = Me.Transaction_Qty_Box
table_object_row.Range(1, 5).Value = Me.Mat_Price_Box
table_object_row.Range(1, 6).Value = Me.cboSupplier_List
table_object_row.Range(1, 7).Value = Me.Order_Date_Box
End Sub
Private Sub cboSupplier_List_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, cboSupplier_List
End Sub
Private Sub Date_Box_AfterUpdate()
On Error Resume Next
Me.Date_Box.Value = CDate(Me.Date_Box)
End Sub
Private Sub Mat_Price_Box_AfterUpdate()
On Error Resume Next
Me.Mat_Price_Box.Value = Format(Me.Mat_Price_Box.Value, "$####.##")
End Sub
Private Sub Material_Code_Box_Change()
On Error Resume Next
Me.Material_Code_Box.Value = StrConv(Me.Material_Code_Box.Value, vbUpperCase)
End Sub
Private Sub Next_Button_Click()
MsgBox "The Transaction Form Will Be Closed"
Unload Me
End Sub
Private Sub Order_Date_Box_AfterUpdate()
On Error Resume Next
Me.Order_Date_Box.Value = CDate(Me.Order_Date_Box)
End Sub
Private Sub Overide_Button_Click()
MsgBox "Are You Sure You Want To Overide"
rspn = InputBox("Enter Password")
If rspn <> "ENVenv11" Then
MsgBox "Wrong password"
End If
Unload Me
Transaction_Form.Show
Dim the_sheet As Worksheet
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Set the_sheet = Sheets("MATERIAL USAGE")
Set table_list_object = the_sheet.ListObjects(1)
Set table_object_row = table_list_object.ListRows.Add
table_object_row.Range(1, 1).Value = Me.Date_Box
table_object_row.Range(1, 4).Value = Me.Material_Code_Box
table_object_row.Range(1, 6).Value = Me.Transaction_Qty_Box
table_object_row.Range(1, 3).Value = Me.Process_Box
table_object_row.Range(1, 2).Value = Me.Customer_Box
End Sub
Private Sub Today_Button_Click()
Date_Box.Value = Date
End Sub
Private Sub Transaction_Qty_Box_AfterUpdate()
On Error Resume Next
Me.Transaction_Qty_Box.Value = CDec(Me.Transaction_Qty_Box.Value)
End Sub
Private Sub Use_Button_Click()
MsgBox "Are You Sure You Want To Remove From Inventory"
Unload Me
Transaction_Form.Show
Dim the_sheet As Worksheet
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Set the_sheet = Sheets("MATERIAL USAGE")
Set table_list_object = the_sheet.ListObjects(1)
Set table_object_row = table_list_object.ListRows.Add
table_object_row.Range(1, 1).Value = Me.Date_Box
table_object_row.Range(1, 4).Value = Me.Material_Code_Box
table_object_row.Range(1, 6).Value = Me.Transaction_Qty_Box
table_object_row.Range(1, 3).Value = Me.Process_Box
table_object_row.Range(1, 2).Value = Me.Customer_Box
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
'Populate Supplier combo box.
Dim rngSupplier As Range
Dim ws As Worksheet
Set ws = Worksheets("Lookup_Lists")
For Each rngSupplier In ws.Range("Suppliers")
Me.cboSupplier_List.AddItem rngSupplier.Value
Next rngSupplier
End Sub
When the add button is pushed the quantity cell in the Received table is populated. This happens no issues with it putting data in the table.
The issue is the formulas do not see the data that the form enters into that cell. All other cell data populates and can be seen by various other formulas I have used to test it. It is just the quantity cell.
Here's what I suspect is happening: The input TextBoxes on your userform contain String. That's all they can ever contain. You're attempting to cast that string as numeric here:
Private Sub Transaction_Qty_Box_AfterUpdate()
On Error Resume Next
Me.Transaction_Qty_Box.Value = CDec(Me.Transaction_Qty_Box.Value)
'Confirm my suspicions:
MsgBox TypeName(Me.Transaction_Qty_Box.Value)
End Sub
But then you're passing that Decimal instance back into the TextBox.Value, which implicitly converts it back to String.
So, you've got the right idea, but you're doing it in the wrong place, I think. Try casting here instead:
table_object_row.Range(1, 6).Value = CDec(Me.Transaction_Qty_Box)
Note that this is already what you're doing with the Me.DateBox:
table_object_row.Range(1, 1).Value = CDate(Me.Date_Box)
You can probably remove the _AfterUpdate event handlers and just dump the textbox values to the sheet. Cast them as needed, and apply formatting directly to the cell if needed.
Related
I have a userform from which I want to import values into a predefined table (called "Overzicht").
I have 12 checkboxes (one for each month) and I want one row for each month if that checkbox is checked. I want to put the Caption of the checkbox in one of the columns in the table.
For example, if I check January, February and March, I want to import all values into a table into three rows where the first row the 'Month' columns says "January", the second one "February" etc.
I have code that checks the number of checked checkboxes and creates the same number of rows. I don´t know how to get correct captions in the rows. This is what I have so far:
Private Sub CommandButton1_Click()
Dim rng As Range
Dim newrow As ListRow
Set rng = ThisWorkbook.Worksheets("Kostenoverzicht").Range("Overzicht")
Dim answer As Integer
'check number of rows to insert based on # of checked months
Dim ctl As MSForms.Control
Dim rows As Long
For Each ctl In Kostenoverzicht.Frame2.Controls
If TypeOf ctl Is MSForms.CheckBox Then
If Kostenoverzicht.Frame2.Controls(ctl.Name).Value = True Then
rows = rows + 1
End If
End If
Next
answer = MsgBox("Are you sure you want to continue?", vbQuestion + vbYesNo + vbDefaultButton1, "Zet in overzicht?")
If answer = vbYes Then
rng.Select
Set newrow = Selection.ListObject.ListRows.Add(alwaysinsert:=True)
With ws
For rows = 1 To rows
newrow.Range.Cells(rows, 1).Value = Me.TextBox1.Value
newrow.Range.Cells(rows, 2).Value = Me.CategorieBox.Value
newrow.Range.Cells(rows, 3).Value = Me.SubCategorieBox.Value
newrow.Range.Cells(rows, 4).Value = Me.BankrekeningBox.Value
If OptionButton1.Value = True Then newrow.Range.Cells(rows, 5).Value = "Af" Else newrow.Range.Cells(1, 5).Value = "Bij"
newrow.Range.Cells(rows, 6).Value = Me.TextBox2.Value
newrow.Range.Cells(rows, 7).Value = Me.CheckBox1.Caption
If OptionButton3.Value = True Then newrow.Range.Cells(rows, 8).Value = "Ja" Else newrow.Range.Cells(1, 8).Value = "Nee"
Next
End With
End If
End Sub
It will give the value "January" to all rows.
I need code to replace the newrow.Range.Cells(rows, 7).Value = Me.CheckBox1.Caption to take the caption of the checked checkbox.
I´ve tried to find my answer on several sites.
Nevermind my first answer, I misunderstood and thought it would always go from jan to some other month. But now It seems it could also be just be sept and nov for example. Find old/wrong answer at the bottom.
Your code is increadibly hard for me to understand for some reason. You check how many rows to insert at the top, then all the rows seem to get the same information put into it since cells 1-6 are values from other non variable/dynamic sources? Im unsure if I understand whats happening.What even is ws? It also kind of calls a userform right? I can"t really rebuilt what you have cuz I don`t quite know.
Best shot:
Private Sub CommandButton1_Click()
Dim rng As Range
Dim newrow As ListRow
Set rng = ThisWorkbook.Worksheets("Kostenoverzicht").Range("Overzicht")
Dim answer As Integer
Dim ctl As MSForms.Control
Dim rows As Long
answer = MsgBox("Are you sure you want to continue?", vbQuestion + vbYesNo + vbDefaultButton1, "Zet in overzicht?")
If Not answer = vbYes Then Exit Sub
For Each ctl In Kostenoverzicht.Frame2.Controls
If TypeOf ctl Is MSForms.CheckBox Then
If Kostenoverzicht.Frame2.Controls(ctl.Name).Value = True Then
Set newrow = rng.ListObject.ListRows.Add(alwaysinsert:=True)
newrow.Range.Cells(rows, 1).Value = Me.TextBox1.Value
newrow.Range.Cells(rows, 2).Value = Me.CategorieBox.Value
newrow.Range.Cells(rows, 3).Value = Me.SubCategorieBox.Value
newrow.Range.Cells(rows, 4).Value = Me.BankrekeningBox.Value
If OptionButton1.Value = True Then newrow.Range.Cells(rows, 5).Value = "Af" Else newrow.Range.Cells(1, 5).Value = "Bij"
newrow.Range.Cells(rows, 6).Value = Me.TextBox2.Value
newrow.Range.Cells(rows, 7).Value = ctl.Name 'Or maybe ctl.Caption ?
If OptionButton3.Value = True Then newrow.Range.Cells(rows, 8).Value = "Ja" Else newrow.Range.Cells(1, 8).Value = "Nee"
End If
End If
Next
End Sub
I hope you see what I'm trying to do here and can fix it to your needs /bug fix it. Like I said, I didnt rebuilt a sheet to test it. Maybe it helps you regardless.
Old:
newrow.Range.Cells(rows, 7).Value = Format(3 + 31 * (rows - 1), "MMMM")
This code should go behind your UserForm
Here are some suggestions for when you're coding:
Use option explicit so you don't have unexpected behavior with undefined variables
Always indent your code (see www.rubberduckvba.com a free tool that help you with that)
Try to separate your logic defining variables and the reusing them
Review and customize the code so it fits your needs.
You can see what's happening in the code by adding a stop and pressing F8 and executing it line by line.
Code:
Option Explicit
Private Sub CommandButton1_Click()
ProcessForm
End Sub
Private Sub ProcessForm()
Dim targetControl As MSForms.control
Dim continue As Boolean
continue = MsgBox("Are you sure you want to continue?", vbQuestion + vbYesNo + vbDefaultButton1, "Zet in overzicht?") = vbYes
' If it's not yes
If Not continue Then Exit Sub
For Each targetControl In Me.Controls
If TypeOf targetControl Is MSForms.CheckBox Then
Select Case targetControl.Value
Case True
' Call the RecordData procedure (remember to add the controls in the parameters)
RecordData targetControl.Caption, Me.TextBox1.Value, Me.TextBox2.Value
Case False
' Do something?
End Select
End If
Next targetControl
End Sub
Private Sub RecordData(ByVal recordMonth As String, ByVal textbox01Value As String, ByVal textbox02Value As String)
Dim targetTable As ListObject
Dim newRow As ListRow
' Refer to the table (no need for the worksheet reference)
Set targetTable = Range("Overzicht").ListObject
' Add a new row an set a reference
Set newRow = targetTable.ListRows.Add
' Refer to the columns by their header (replace with yours)
newRow.Range.Cells(1, targetTable.ListColumns("Month").Index).Value = recordMonth
newRow.Range.Cells(1, targetTable.ListColumns("Textbox1").Index).Value = textbox01Value
newRow.Range.Cells(1, targetTable.ListColumns("Textbox2").Index).Value = textbox02Value
End Sub
Let me know if it works or you need more help
I need your help. It seems what I have written in code does not accomplish what I am trying to do here.
The objective would be to have 2 userform combo boxes one for the (floor) values which are manually added once [3,4,5] and the other combo boxes (offices) in which values are dynamically added based on the selection made in the floor selection box.
Let's say for example that if I chose the value [3] in my floor combo box that the office combo box would contain the following values:
A-01
A-02
A-03
A-04
A-05
A-06
A-07
A-08
I thought this code would work but it doesn't:
'Cells(row, col)
Private Sub floor_Change()
lRow = Sheets("Office Spaces").UsedRange.Rows.Count
With Sheets("Office Spaces")
For i = 2 To lRow
If .Cells(i, 1).Value = UserForm1.floor.Value Then
UserForm1.office.AddItem .Cells(i, 2).Value
End If
Next i
End With
End Sub
Here's what the data looks in my excel sheet:
'Cells(row, col)
Private Sub floor56_Change()
UserForm1.office.Clear
Dim sh
Dim rw
Set sh = Sheets("Office Spaces")
For Each rw In sh.Rows
If sh.Cells(rw.row, 1).Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (sh.Cells(rw.row, 2).Value)
End If
Next rw
End Sub
or
Private Sub floor_Change()
If UserForm1.floor.Value <> "" Then
UserForm1.office.Clear
Dim ws
Set ws = ThisWorkbook.Worksheets("Office Spaces")
Dim rng
Set rng = ws.Range("A:A")
For Each cell In rng
If cell.Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (cell.Offset(0, 1).Value)
End If
Next cell
End If
End Sub
I am facing a problem in getting the sequence of the unique numbers(Serial number) when the userform is closed and opened later on. Firstly, when I fill the data in the userform everything is captured in the excel sheet perfectly with correct sequence; if I close the userform and run the code by filling the userform with new data the unique ID's are again starting from "1" but not according to the excel sheet row number which was previously saved.
Below is the code I tried:
Private Sub cmdSubmit_Click()
Dim WB As Workbook
Dim lr As Long
Set WB = Workbooks.Open("C:\Users\Desktop\Book2.xlsx")
Dim Database As Worksheet
Set Database = WB.Worksheets("Sheet1")
eRow = Database.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
lr = Database.Range("a65536").End(xlUp).Row
With Sheets("Sheet1")
If IsEmpty(.Range("A1")) Then
.Range("A1").Value = 0
Else
Database.Cells(lr + 1, 1) = Val(Database.Cells(lr, 1)) + 1
End If
End With
Database.Cells(eRow, 4).Value = cmbls.Text
Database.Cells(eRow, 2).Value = txtProject.Text
Database.Cells(eRow, 3).Value = txtEovia.Text
Database.Cells(eRow, 1).Value = txtUid.Text
Call UserForm_Initialize
WB.SaveAs ("C:\Users\Desktop\Book2.xlsx")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim maxNumber
If Not Intersect(Target, Range("B:B")) Is Nothing Then
' don't run when more than one row is changed
If Target.Rows.Count > 1 Then Exit Sub
' if column A in the current row has a value, don't run
If Cells(Target.Row, 1) > 0 Then Exit Sub
' get the highest number in column A, then add 1 and write to the
' current row, column A
maxNumber = Application.WorksheetFunction.Max(Range("A:A"))
Target.Offset(0, -1) = maxNumber + 1
End If
End Sub
Private Sub UserForm_Initialize()
With txtUid
.Value = Format(Val(Cells(Rows.Count, 1).End(xlUp)) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
In this image if you see unique id's are repeating 1 and 2, but I need as 1,2,3,4....
I think this is where the issue is coming from. You need to re-calculate the last row every time the user form is Initialized.
Private Sub UserForm_Initialize()
Dim ws as Worksheet: Set ws = Thisworkbook.Sheets("Database")
With txtUid
.Value = Format(ws.Range("A" & ws.Rows.Count).End(xlUp) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
It's always risky to use row numbers or [max range value +1] as a sequence number.
Safer to use something like a name scoped to the worksheet, which has a value you can increment. Then the sequence is independent of your data.
E.g.
Function GetNextSequence(sht As Worksheet) As Long
Const SEQ_NAME As String = "SEQ"
Dim nm As Name, rv As Long
On Error Resume Next
Set nm = sht.Names(SEQ_NAME)
On Error GoTo 0
'add the name if it doesn't exist
If nm Is Nothing Then
Set nm = sht.Names.Add(Name:=SEQ_NAME, RefersToR1C1:="=0")
End If
rv = Evaluate(nm.Value) + 1
nm.Value = rv
GetNextSequence = rv
End Function
I have a table that ranges from F2 to G230 . The F column is employee number and G column is employee name. Im trying to make a simple program that registers food orders for the employees and exports the data into a table. Everything works fine except when I choose a employee from a drop down list I want the employee number to appear in a textbox.
Here is my whole code:
Private Sub cmdbutton_add_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("listi yfir skráningar")
'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.combobox_name.Value) = "" Then
Me.combobox_name.SetFocus
MsgBox "Please complete the form"
Exit Sub
End If
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.textbox_staffnr.Value
ws.Cells(iRow, 2).Value = Me.combobox_name.Value
ws.Cells(iRow, 3).Value = Me.combobox_rettir.Value
ws.Cells(iRow, 4).Value = Me.textbox_verd.Value
ws.Cells(iRow, 5).Value = Me.textbox_dags.Value
MsgBox "Komið :)", vbOKOnly + vbInformation, "Komið"
'clear the data
Me.combobox_name.Value = ""
Me.combobox_name.SetFocus
Unload Me
End Sub
Private Sub Cmdbutton_close_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub combobox_name_Change()
textbox_staffnr.Value = Application.VLookup(Me.combobox_name.Value, Sheet3.Range("F2:G230"), 1, 0)
End Sub
Private Sub combobox_rettir_Change()
textbox_verd.Value = Application.VLookup(Me.combobox_rettir.Value, Sheet3.Range("C2:D23"), 2, 0)
End Sub
Private Sub Name_Click()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub textbox_staffnr_Change()
End Sub
Private Sub textbox_verd_Change()
End Sub
Private Sub UserForm_Initialize()
textbox_dags.Value = Format(Date, "dd/mm/yyyy")
End Sub
And here Im getting error:
Private Sub combobox_name_Change()
textbox_staffnr.Value = Application.VLookup(Me.combobox_name.Value, Sheet3.Range("F2:G230"), 1, 0)
End Sub
Please help.
EDIT: From user's comment:
The number is in column 1 and the name is in column 2
In that case, Vlookup won't work, you'll need to use Index/Match, or a Range.Find.Offset. Personally I prefer the Range.Find.Offset while in VBA:
Dim rngFound as Range
Set rngFound = Sheet3.Range("G2:G230").Find(Me.combobox_name.Value, , xlValues, xlWhole)
If not rngFound is Nothing Then textbox_staffnr.Value = rngFound.Offset(0, -1).Text
I have checkboxes in my User form and based on selection Of ID from Checkboxes, I want to activate the sheets for particular user in my workbook. I came across some portions of the following code but it's not working properly.
Option Explicit
Private Sub Add_Click()
Dim ctrl As Control
For Each ctrl In UserForm1.Controls
If TypeName(ctrl) = "CheckBox" Then
TransferValues ctrl
End If
Next
End Sub
Sub TransferValues(cb As MSForms.CheckBox)
Dim ws As Worksheet
Dim emptyRow As Long
If cb.Value = True Then
'Define the worksheet based on the CheckBox.Name property:
Set ws = Sheets(Left(cb.Name, 1))
emptyRow = WorksheetFunction.CountA(ws.Range("F:F")) + 1
With ws
If Trim(Me.ComboBox3.Value) = "" Or Trim(Me.ComboBox6.Value) = "" Then
MsgBox ("Please enter text in all fields")
Exit Sub
End If
If WorksheetFunction.CountIf(ws.Range("F:F"), ComboBox3.Value) = 0 Or WorksheetFunction.CountIf(ws.Range("G:G"), ComboBox6.Value) = 0 Then
Cells(emptyRow, 6).Value = ComboBox3.Value
Cells(emptyRow, 7).Value = ComboBox6.Value
Cells(emptyRow, 8).Value = TextBox1.Value
Else
MsgBox ("Warning:Duplicate Entries found. Please update the existing entries")
End If
End With
End If
End Sub
Found solution by own. Please use the following code for such kind of issues if anyone face.
Private Sub CommandButton1_Click()
Dim ctrl As Control
For Each ctrl In Userform1.Controls
If TypeName(ctrl) = "CheckBox" Then
TransferValues ctrl
End If
Next
End Sub
Sub TransferValues(cb As MSForms.CheckBox)
Dim ws As Worksheet
Dim emptyRow As Long
'Dim ID As String
If cb.Value = True Then
Set ws = Sheets(Left(cb.Caption, 6))
If Trim(Me.ComboBox3.Value) = "" Or Trim(Me.ComboBox6.Value) = "" Then
MsgBox ("Please Enter the text in All Fields")
End If
emptyRow = WorksheetFunction.CountA(ws.Range("F:F")) + 1
With ws
If WorksheetFunction.CountIf(ws.Range("F:F"), ComboBox3.Value) = 0 Or WorksheetFunction.CountIf(ws.Range("G:G"), ComboBox6.Value) = 0 Then
.Cells(emptyRow, 6).Value = ComboBox3.Value
.Cells(emptyRow, 7).Value = ComboBox6.Value
.Cells(emptyRow, 8).Value = TextBox1.Value
Else
MsgBox ("Warning:Duplicate Entries Found. Please edit existing entries")
End If
End With
End If
End Sub