Excel userform combo box select sheet to put values in - vba

Hi i am trying to program a user form in excel that a user inputs the information and can select the worksheet that they want the information that was entered in to go to that spread sheet.
This is what i have so far.
Dim iRow As Long
Dim sheet As String
sheet = ComboBox1.Value
Worksheets(sheet).Activate
iRow = sheet.Cells.Find(what:="*", seatchOrder:=xlRows, searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
when i run the user form and select the worksheet in the combo box and hit the command button to run the form i get the error "invalid qualifier"
it highlights sheet.cells
here is the entire code if it helps:
Private Sub ComboBox1_Change()
End Sub
Private Sub CommandButton1_Click()
'get item button
Dim sheet As String
UserForm8.Hide
MsgBox ("Select an item to update")
sheet = ComboBox1.Value
Worksheets(sheet).Activate
Set ProjRng = Application.InputBox(Message, Title, "", 377, 58, , , 8)
ProjSel = ProjRng.Cells.Row
Label1.Enabled = True
Label2.Enabled = True
Label3.Enabled = True
Label4.Enabled = True
Label8.Enabled = True
Label10.Enabled = True
TextBox1.Enabled = True
TextBox2.Enabled = True
TextBox3.Enabled = True
TextBox4.Enabled = True
TextBox8.Enabled = True
TextBox10.Enabled = True
TextBox10.Locked = False
CommandButton1.Enabled = True
ComboBox1.Enabled = True
UserForm8.TextBox1.Value = ActiveSheet.Cells(ProjSel, 1).Value
UserForm8.TextBox2.Value = ActiveSheet.Cells(ProjSel, 2).Value
UserForm8.TextBox3.Value = ActiveSheet.Cells(ProjSel, 3).Value
UserForm8.TextBox4.Value = ActiveSheet.Cells(ProjSel, 4).Value
UserForm8.TextBox8.Value = ActiveSheet.Cells(ProjSel, 8).Value
UserForm8.TextBox11.Value = ActiveSheet.Cells(ProjSel, 6).Value
UserForm8.Show
End Sub
Private Sub CommandButton2_Click()
'Update button to update the remaing quantity amount
Dim iRow As Long
Dim sheet As String
sheet = ComboBox1.Value
Worksheets(sheet).Activate
iRow = sheet.Cells.Find(what:="*", seatchOrder:=xlRows, searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
With Worksheets("ChemLog")
.Cells(iRow, 6).Value = Me.TextBox12
End With
With sheet
.Cells(iRow, 1).Value = Me.TextBox1.Value
end with
'continue above with columns according to log
End Sub
Private Sub TextBox10_Change()
End Sub
Private Sub TextBox11_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem ("Standards")
ComboBox1.AddItem ("Acids,Bases, and Buffers")
ComboBox1.AddItem ("Solvents and Flammables")
End Sub

As well as the spelling error, sheet is a string, so it requires:
Worksheets(sheet).Cells.Find(..
which is the reason for the specific error message you receive.

Related

Loop through each cell in worksheet a and if value true in in worksheet B to replace cell value with "reserved"

I am trying to look through data that a user has selected in a listbox, when the user clicks "Reserve offcuts" then all the selected lines of data that I have copied over on sheet "Offcut Basket" is then placed onto the database worksheet which is labled as "wo2" I want my code to then look through each line of column E and if that ID matches the ID on the database sheet it will then input the value as "Snumber" which is the value which is captured from the textbox on the userform in the column next to the ID
my Problem is that my code that looks through each cell is asking for an object, I see that i need to declare the objects meaning on which sheet i need to look through, but just a better understanding of where i have put my loop will be a great help. Thanks everyone
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Set v = Worksheets("Offcut Basket").Cells(Worksheets("Offcut Basket").Rows.Count, "E").End(xlUp)
With Worksheets("Offcut Database")
For Each cell In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp))
If Int(cell.Value2) = Int(r.Value2) Then
Cells(v.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
End If
Next cell
End With
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub
I figured it out,
Private Sub CommandButton11_Click()
'Reserve offcuts with job number
If Offcut11.OffcutJob.Value = "" Then
MsgBox "Please insert SAGE job number!", vbExclamation, "JDS"
Exit Sub
End If
Dim snumber As String
snumber = Offcut11.OffcutJob.Value
Dim wo1 As Workbook
Dim wo2 As Workbook
Set wo1 = Workbooks("Fabrication Schedule v2")
Do
Set wo2 = Workbooks.Open(Filename:="J:\Database\Offcut Database.xlsx")
If wo2.ReadOnly Then Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until Not wo2.ReadOnly
Application.Visible = False
Application.ScreenUpdating = False
wo1.Activate
Sheets("Offcut Basket").Activate
Range("A2:F200").Copy
wo2.Activate
Sheets("Offcut Basket").Activate
Range("A1").PasteSpecial xlPasteValues
Dim acr As String
Dim v As Range
Dim Found As Range
Set v = Sheets("Offcut Basket").Range("E1", Range("E" & Rows.Count).End(xlUp))
For Each cell In v
Sheets("Offcut Database").Activate
Set Found = Sheets("Offcut Database").Range("A2", Range("E" & Rows.Count).End(xlUp)).Find(cell, LookAt:=xlWhole)
Cells(Found.Row, 2).Select
acr = ActiveCell.Row
Cells(acr, "F").Value = snumber
Next cell
Application.DisplayAlerts = False
wo2.Save
wo2.Close
wo1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Offcuts have been reserved", vbExclamation, "JDS"
End Sub

I can't open a userform from a main userform

I'm Using Excel 2013 vba. I have 2 Forms: frmMain and . In frmMain, I only have a cmd button with a code UserForm1.show ,however i can't open the UserForm1.
Here's my code:
Private Sub Workbook_Open()
Application.Visible = False 'This code hides the workbook
UserForm1.Show 'Brings the UserForm
End Sub
'Module1 Code..
Sub hidden()
Sheet1.Visible = False
End Sub
screenshot of my UserForm1
Code for UserForm1...
'Application.ScreenUpdating = False
'Sheets("Sheet1").Visible = True
Private Sub cmbCalltype_Change()
'==========sayon rani dri=======
'If cmbCalltype.List(cmbCalltype.ListIndex) = "Training" Then
' cmbGc.Enabled = False
'ElseIf cmbCalltype.List(cmbCalltype.ListIndex) = "Wrong GC" Then
' cmbGc.Enabled = False
'ElseIf cmbCalltype.List(cmbCalltype.ListIndex) = "Wrong Number" Then
' cmbGc.Enabled = False
'ElseIf cmbCalltype.List(cmbCalltype.ListIndex) = "Resident" Then
' cmbGc.Enabled = False
'Else
' cmbGc.Enabled = True
'End If
If cmbCalltype.Text = "Training" Then
cmbGc.Enabled = False
ElseIf cmbCalltype.Text = "Resident" Then
cmbGc.Enabled = False
ElseIf cmbCalltype.Text = "Wrong GC" Then
cmbGc.Enabled = False
ElseIf cmbCalltype.Text = "Wrong Number" Then
cmbGc.Enabled = False
Else
cmbGc.Enabled = True
End If
End Sub
Private Sub cmdApplicationshow_Click()
Application.Visible = True 'This will open the excel file...
End Sub
Private Sub cmdClear_Click()
'==========sayon rani dri=======
'Call UserForm_Initialize
txtName.Value = ""
cmbCalltype.Value = ""
cmbGc.Value = ""
cmbVisit.Value = ""
End Sub
Private Sub cmdHidden_Click()
Application.Visible = False 'This will open the excel file...
End Sub
Private Sub cmdMove_Click()
'Dim emptyRow As Long
'Sheet1.Activate 'Make Sheet1 active
'emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
'Transfer information
'Cells(emptyRow, 1).Value = txtName.Value
'Cells(emptyRow, 2).Value = cmbCalltype.Value
'Cells(emptyRow, 3).Value = cmbVisit.Value
With Sheet1
With .Range("A" & .Rows.Count).End(xlUp)
.Offset(1).Resize(1, 4).Value = Array(txtName.Value, cmbCalltype.Value, cmbGc.Value, cmbVisit.Value)
End With
txtLeasing.Value = Application.CountIf(.Columns(2), "Leasing") 'counting the number of instances leasing text occur
txtGc.Value = Application.CountIf(.Columns(3), "Yes")
'txtYes.Value = Application.CountIf(.Columns(4), "Yes")
'txtNo.Value = Application.CountIf(.Columns(4), "No")
txtPercentage.Value = txtGc.Value / txtLeasing.Value * 100
''==================
txtVisLeasing.Value = txtLeasing.Value
txtTotvisit.Value = Application.CountIf(.Columns(4), "Yes")
txtVisitper.Value = txtTotvisit.Value / txtVisLeasing * 100
End With
End Sub
Private Sub UserForm_Initialize()
'Worksheets("Sheet1").Activate
'Sheets("Sheet1").Visible = False
txtName.Value = "" 'Empty Customer
cmbCalltype.Value = "" 'Empty Call Type
cmbGc.Value = "" 'Empty GC
cmbVisit.Value = "" 'Empty Visit
cmbCalltype.Clear
With cmbCalltype
.AddItem "Leasing"
.AddItem "Training"
.AddItem "Resident"
.AddItem "Wrong GC"
.AddItem "Wrong Number"
End With
cmbGc.Clear
With cmbGc
.AddItem "Yes"
.AddItem "No"
End With
cmbVisit.Clear
With cmbVisit
.AddItem "Yes"
.AddItem "No"
End With
txtName.SetFocus
End Sub
Is the instance of UserForm1 called from Workbook_Open() same as the instance of UserForm1 called from frmMain ?
If Yes, then create a Module and declare the instance of UserForm1 in Module1 as Public.
If No, then declare a form level instance of UserForm1 in frmMain.
Something like below.
'frmMain Code
Dim fUser As UserForm1
Private Sub CommandButton1_Click()
If fUser Is Nothing Then
fUser = New UserForm1
End If
fUser.Show
End Sub

Excel keeps crashing with Worksheet_selectionChange

I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.

How to update data of an excel sheet in a userform with vba

U would like to know how i can retrieve data from an excel sheet and update it in a userform.
on the picture you can see what the userform looks like.
What i would like to do is make another userform that can search for a specific reference in the sheet and update some cells of that specific row.
This is the code I have now to insert data into the sheet.
Private Sub cmdClear_Click()
' Clear the form
For Each ctl In Me.Controls
If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
ctl.Value = ""
ElseIf TypeName(ctl) = "CheckBox" Then
ctl.Value = False
End If
Next ctl
End Sub
Private Sub cmdSend_Click()
Dim RowCount As Long
Dim ctl As Control
' Check user input
If Me.combTechnieker.Value = "" Then
MsgBox "Dag vreemdeling! Welke van de 4 Mongolen ben je?", vbExclamation, "RMA invoer"
Me.combTechnieker.SetFocus
Exit Sub
End If
If Me.txtPcwRef.Value = "" Then
MsgBox "Vul onze referentie in!", vbExclamation, "RMA invoer"
Me.txtPcwRef.SetFocus
Exit Sub
End If
If Me.txtKlant.Value = "" Then
MsgBox "Vul de naam van de klant in!", vbExclamation, "RMA invoer"
Me.txtKlant.SetFocus
Exit Sub
End If
If Me.txtMerk.Value = "" Then
MsgBox "Vul het merk in!", vbExclamation, "RMA invoer"
Me.txtMerk.SetFocus
Exit Sub
End If
If Me.txtMerkRef.Value = "" Then
MsgBox "Vul de referentie van de fabrikant in!", vbExclamation, "RMA invoer"
Me.txtMerkRef.SetFocus
Exit Sub
End If
If Me.txtProduct.Value = "" Then
MsgBox "Vul het product in!", vbExclamation, "RMA invoer"
Me.txtProduct.SetFocus
Exit Sub
End If
If Me.txtSerienummer.Value = "" Then
MsgBox "Vul het serienummer in!", vbExclamation, "RMA invoer"
Me.txtSerienummer.SetFocus
Exit Sub
End If
If Me.txtProbleem.Value = "" Then
MsgBox "Vul de probleem omschrijving in!", vbExclamation, "RMA invoer"
Me.txtProbleem.SetFocus
Exit Sub
End If
If Me.txtOnderdelen.Value = "" Then
MsgBox "Bent u zeker dat er geen onderdelen achterblijven. Indien ja. Vul N/A in", vbExclamation, "RMA invoer"
Me.txtOnderdelen.SetFocus
Exit Sub
End If
' Write data to worksheet
RowCount = Worksheets("RMA 2016").Range("A1").CurrentRegion.Rows.Count
With Worksheets("RMA 2016").Range("A1")
.Offset(RowCount, 0).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 1).Value = "Open"
.Offset(RowCount, 3).Value = Me.txtPcwRef.Value
.Offset(RowCount, 4).Value = Me.txtKlant.Value
.Offset(RowCount, 5).Value = Me.txtMerk.Value
.Offset(RowCount, 6).Value = Me.txtMerkRef.Value
.Offset(RowCount, 7).Value = Me.txtProduct.Value
.Offset(RowCount, 8).Value = Me.txtSerienummer.Value
.Offset(RowCount, 9).Value = Me.txtOnderdelen.Value
.Offset(RowCount, 10).Value = Me.txtProbleem.Value
.Offset(RowCount, 13).Value = Me.combTechnieker.Value
If Me.chkGarantie.Value = True Then
.Offset(RowCount, 2).Value = "Ja"
Else
.Offset(RowCount, 2).Value = "Nee"
End If
End With
' Clear the form
For Each ctl In Me.Controls
If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
ctl.Value = ""
ElseIf TypeName(ctl) = "CheckBox" Then
ctl.Value = False
End If
Next ctl
End Sub
Private Sub UserForm_Click()
End Sub
I have created a small example to showcase how the general mechanics of loading, saving and deleting a record can work together with the form. When you try to save a record with non-existing ID, it will append a new record to the table. This should be very close to what you are asking and shows you how to shuffle data between a user form and a worksheet.
Private Sub cmdLoad_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to load the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' product ID is not found
MsgBox "Product ID " & Me.txtId & " doesn't exist."
Exit Sub
Else
' product ID is found -- fill out the form
Me.txtId = rngId.Offset(0, 0)
Me.txtName = rngId.Offset(0, 1)
Me.txtNote = rngId.Offset(0, 2)
End If
End Sub
Private Sub cmdSave_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to load the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' if product ID is not found, append new one to the end of the table
With rngIdList
Set rngId = .Offset(.Rows.Count, 0).Resize(1, 1)
End With
End If
' update excel record
rngId.Offset(0, 0) = Me.txtId
rngId.Offset(0, 1) = Me.txtName
rngId.Offset(0, 2) = Me.txtNote
End Sub
Private Sub cmdDelete_Click()
' check if provided product ID is not empty
If Len(Trim(Me.txtId)) = 0 Then
MsgBox "Enter product ID to delete the record."
Exit Sub
End If
' try to retrieve the product by ID
Dim rngIdList As Range, rngId As Range
Set rngIdList = ActiveSheet.Range([a2], [a2].End(xlDown))
Set rngId = rngIdList.Find(Me.txtId, LookIn:=xlValues)
If rngId Is Nothing Then
' product ID is not found -- nothing to delete
MsgBox "Product ID " & Me.txtId & " doesn't exist."
Exit Sub
Else
' product ID is found -- delete the entire line
rngId.EntireRow.Delete
End If
End Sub
Here is a link that will explain how to do this.
http://www.onlinepclearning.com/edit-and-delete-from-a-userform/
You essentially need to record a macro using an advanced filter that filters your data based on whatever criteria you want. That data can then be used to feed a listbox in your userform using a dynamic name range where your filtered data is copied too. You can then write some code that allows it feed empty text boxes in the userform when double clicked. Then using a recorded macro that utilizes the 'find' function of excel it can find the updated entry (if it has a unique ID) and replace the old values with the new ones.
The link provided will walk through this step by step. You will just need to modify to fit in your workbook.
Hope this helps!
Example of a project I did:
'this is my recorded filter
Sub FilterData()
'
' FilterData Macro
'
'
Sheets("Propert Data").Range("A6:M80").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Sheet2!Criteria"), CopyToRange:=Range( _
"Sheet2!Extract"), Unique:=False
End Sub
'This feeds the listbox
Dim ws As Worksheet
'Set Worksheet Variable
Set ws = Sheet2
'Run Filter
FilterLoans 'this is a recorded macro
'Add named range to rowsource
If ws.Range("A5").Value = "" Then
Me.loanlist.RowSource = ""
Else
Me.loanlist.RowSource = "FilterLoans" 'this is a dynamic name range
End If
'This feeds the empty cells
Private Sub loanlist_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim i As Integer
On Error Resume Next
i = Me.loanlist.ListIndex
Me.edloannametxt.Value = Me.loanlist.Column(0, i)
Me.edpropnametxt.Value = Me.loanlist.Column(1, i)
Me.edloantypecbx.Value = Me.loanlist.Column(2, i)
Me.edbalancetxt.Value = Me.loanlist.Column(3, i)
Me.edbalancetxt.Value = Format(Val(edbalancetxt.Value), "$#,###")
Me.edpmttxt.Value = Me.loanlist.Column(4, i)
Me.edpmttxt.Value = Format(Val(edpmttxt.Value), "$#,###")
Me.edannualtxt.Value = Me.loanlist.Column(5, i)
Me.edannualtxt.Value = Format(Val(edannualtxt.Value), "$#,###")
Me.edratetxt.Value = Me.loanlist.Column(6, i)
Me.edratetxt.Value = Format(Val(edratetxt.Value), "Percent")
Me.edamtxt.Value = Me.loanlist.Column(7, i)
Me.edbbtcbx.Value = Me.loanlist.Column(8, i)
Me.uidtxt.Value = Me.loanlist.Column(9, i)
End Sub
'this finds and updates that old data
Private Sub updateloancmd_Click()
Dim findvalue As Range
Dim cNum As Integer
Dim DataSH As Worksheet
Application.ScreenUpdating = False
Set DataSH = Sheet10
Set findvalue = DataSH.Range("K:K"). _
Find(What:=Me.uidtxt.Value, LookIn:=xlValues, LookAt:=xlWhole)
findvalue = uidtxt.Value
If findvalue = "" Then
Exit Sub
Else
findvalue.Offset(0, -1) = edbbtcbx.Value
findvalue.Offset(0, -2) = edamtxt.Value
findvalue.Offset(0, -3) = edratetxt.Value
findvalue.Offset(0, -5) = edpmttxt.Value
findvalue.Offset(0, -6) = edbalancetxt.Value
findvalue.Offset(0, -7) = edloantypecbx.Value
findvalue.Offset(0, -8) = edpropnametxt.Value
findvalue.Offset(0, -9) = edloannametxt.Value
End If
End Sub

Excel VBA automatically updating columns (Date)

I am creating a user form that does Customer Returns. I wish to have a (Status)column that will automatically update itself. It refers to the Arrival Date of the product. It works, but, when I change the system date, the status bar does not change. What do I have to do to make it update regularly? The following is the code of what ever is working.
P.S it the code works fine when entering the values. But doesn't self update
Option Explicit
Dim dDate As Date
Private Sub cbP_CodeCR_Change()
Dim row As Long
row = cbP_CodeCR.ListIndex + 2
End Sub
Private Sub Fill_My_Combo(cbo As ComboBox)
Dim wsInventory As Worksheet
Dim nLastRow As Long
Dim i As Long
Set wsInventory = Worksheets("Inventory")
nLastRow = wsInventory.Cells(Rows.Count, 1).End(xlUp).row ' Finds last row in Column 1
cbo.Clear
For i = 2 To nLastRow 'start at row 2
cbo.AddItem wsInventory.Cells(i, 1)
Next i
End Sub
Private Sub cmdCancel_Click()
Unload CustomerReturn
End Sub
Private Sub cmdEnter_Click()
Dim cust_ID As Integer
Dim prod_Code As Integer
Dim arr_date As Date
Dim stat As String
Dim status As String
Dim rowPosition As Integer
rowPosition = 1
Sheets("Customer Return").Select
Sheets("Customer Return").Cells(1, 1).Value = "Customer ID"
Sheets("Customer Return").Cells(1, 2).Value = "Product Code"
Sheets("Customer Return").Cells(1, 3).Value = "Arrival Date"
Sheets("Customer Return").Cells(1, 4).Value = "Status"
Do While (Len(Worksheets("Customer Return").Cells(rowPosition, 1).Value) <> 0)
rowPosition = rowPosition + 1
Loop
cust_ID = txtC_IDCR.Text
Sheets("Customer Return").Cells(rowPosition, 1).Value = cust_ID
prod_Code = cbP_CodeCR.Text
Sheets("Customer Return").Cells(rowPosition, 2).Value = prod_Code
arr_date = txtA_DateCR.Text
Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
If ((arr_date - Date) <= 0) Then
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Arrived"
Else
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Waiting for Delivery"
End If
End Sub
Sub Recalc()
Range("C:C").Value = Format("dd/mm/yyyy")
Range("D:D").Calculate
Call StartTime
End Sub
Sub StartTime()
SchedRecalc = Now + TimeValue("00:00:10")
Application.OnTime SchedRecalc, "Recalc"
End Sub
Sub EndTime()
On Error Resume Next
Application.OnTime EarliestTime:=SchedRecalc, _
Procedure:="Recalc", Schedule:=False
End Sub
Private Sub txtA_DateCR_AfterUpdate()
With txtA_DateCR
If .Text = "" Then
.ForeColor = &HC0C0C0
.Text = "dd/mm/yyyy"
End If
End With
End Sub
Private Sub txtA_DateCR_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Exit Sub
If Mid(txtA_DateCR.Value, 4, 2) > 12 Then
MsgBox "Invalid date, make sure format is (dd/mm/yyyy)", vbCritical
txtA_DateCR.Value = vbNullString
txtA_DateCR.SetFocus
Exit Sub
End If
dDate = DateSerial(Year(Date), Month(Date), Day(Date))
txtA_DateCR.Value = Format(txtA_DateCR.Value, "dd/mm/yyyy")
dDate = txtA_DateCR.Value
End Sub
Private Sub txtA_DateCR_Enter()
With txtA_DateCR
If .Text = "dd/mm/yyyy" Then
.ForeColor = &H80000008
.Text = ""
End If
End With
End Sub
Private Sub UserForm_Initialize()
txtA_DateCR.ForeColor = &HC0C0C0
txtA_DateCR.Text = "dd/mm/yyyy"
cmdEnter.SetFocus
Fill_My_Combo Me.cbP_CodeCR
End Sub
Deeply appreciate any help if possible.
This should work in the most common scenario when time flows forward:
Create a utility module AnyNameIsGood with this code (it comes from Sean Cheshire's answer to similar question with the Recalc body adjusted)
Dim ScheduledRecalc As Date
Sub Recalc()
Sheets("Customer Return").Range("D:D").Calculate
Call StartTime
End Sub
Sub StartTime()
ScheduledRecalc = Now + TimeValue("00:00:10")
Application.OnTime ScheduledRecalc, "Recalc"
End Sub
Sub EndTime()
On Error Resume Next
Application.OnTime EarliestTime:=ScheduledRecalc, Procedure:="Recalc", Schedule:=False
End Sub
Add this code to the ThisWorkbook module to prevent unwanted behavior while closing the module:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call EndTime
End Sub
In the CustomerReturn module (the form) change your current code to
Private Sub cmdEnter_Click()
' ...
arr_date = txtA_DateCR.Text
Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
Sheets("Customer Return").Cells(rowPosition, 3).NumberFormat = "dd\/mm\/yyyy"
Sheets("Customer Return").Cells(rowPosition, 4).FormulaR1C1 = "=IF(DAYS(R[0]C[-1],TODAY())<=0,""Arrived"",""Waiting for Delivery"")"
End Sub
It will format the date cells and it will make the generated Status formulas sensitive to the Excel's Calculate Now (F9) event.
Somewhere (e.g. in the Workbook_Open event handler) call the StartTime utility procedure (once). It will trigger automatic recalculation of the Status column.
Steps 1, 2, 4 are optional and not needed if the refresh does not have to be automatic as the end user can refresh the statuses anytime by pressing F9