THIS IS AN UPDATE TO MY ORIGINAL QUESTION OF 12/5. IT INCLUDES THE COMPLETE CODE USED FOR THE WORKBOOK.
MANY, MANY THANKS.!!!
I created a form that has 3 text boxes for data entry. It also has 3 buttons to choose from after data entry. The below code populates the table with the information from the form plus some additional information from the header in the worksheet when an "Update" button is pressed. This worked fine until I entered the code line " Reg1.SetFocus". I did this to set the focus back to the first text box after pressing the update button. I now get "Run-Time error 13" that debugs to this line of code:
".Reg4 = Application.WorksheetFunction.VLookup(CLng(Me.Reg1), Sheet2.Range("Lookup"), 4, 0)"
This all goes away if I delete the "Reg1.SetFocus" line in the prior sub.
The complete code for the workbook is:
Option Explicit
'Private Sub AmountEntry_Exit(ByVal Cancel As MSForms.ReturnBoolean)
AmountEntry.Value = Format(AmountEntry.Value, "$#,#00.00")
End Sub
Private Sub AmountEntry_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
End Sub
Private Sub ClearButton_Click()
Dim Ctrl As MSForms.Control
F or Each Ctrl In Input_Form.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
Ctrl.Text = ""
Case "OptionButton"
Ctrl.Value = False
Case "ComboBox"
Ctrl.ListIndex = -1
End Select
Next Ctrl
'DateSelect.Value = Date
End Sub
Private Sub CloseButton_Click()
Unload Input_Form
End Sub
Private Sub UpdateTableButton_Click()
Dim LastRow As Range
Dim AssistanceTable As ListObject
'Add row to bottom of Assistance table
ActiveSheet.ListObjects("Assistance").ListRows.Add
'Enter data from form into our new row
Set AssistanceTable = ActiveSheet.ListObjects("Assistance")
Set LastRow = AssistanceTable.ListRows(AssistanceTable.ListRows.Count).Range
With LastRow
.Cells(1, 1) = Range("fund").Value
.Cells(1, 2) = Reg1.Value
.Cells(1, 3) = Reg2.Value
.Cells(1, 4) = Range("mass_date").Value
.Cells(1, 5) = Reg3.Value
.Cells(1, 6) = Range("mass_time").Value
End With
Dim Ctrl As MSForms.Control
For Each Ctrl In Input_Form.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
Ctrl.Text = ""
Case "OptionButton"
Ctrl.Value = False
Case "ComboBox"
Ctrl.ListIndex = -1
End Select
'Set focus to Parishioner ID
On Error Resume Next
Reg1.SetFocus
On Error GoTo 0
Next Ctrl
End Sub
Private Sub UpdateTableButton_Enter()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub Reg1_AfterUpdate()
'Check to see if value exists
If WorksheetFunction.CountIf(Sheet2.Range("a:a"), Me.Reg1.Value) = 0 Then
MsgBox "Parishioner not yet in database"
Me.Reg1.Value = ""
Exit Sub
End If
'Lookup values based on first control
With Me.Reg4 = Application.WorksheetFunction.VLookup(CLng(Me.Reg1), Sheet2.Range("Lookup"), 4, 0)
End With
End Sub
Private Sub ComboBox2_Change()
Range("b3").Value = Format(Me.ComboBox2.Value, "dd mmm,yyyy")
End Sub
Private Sub UserForm_Initialize()
Me.Reg3.AddItem "Check"
Me.Reg3.AddItem "Cash"
End Sub
Related
I'm putting together a spreadsheet that should populate checkboxes in a specific column when the spreadsheet opens if the appropriate A Column/Row is not empty. It should also remove checkboxes when it finds that same A column to be empty. My VB is correctly creating the checkboxes, but I cannot figure out how to tell the code to delete the checkbox from a specific cell.
Most articles I find mention removed ALL checkboxes, but I'm looking to do it conditionally. Any guidance would be greatly appreciated.
Private Sub Workbook_Open()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
For x = 2 To 1000
If ws.Cells(x, 1) <> "" Then
Call Add_CheckBox(CInt(x))
Else
Call Delete_CheckBox(CInt(x))
End If
Next x
End Sub
Private Sub Add_CheckBox(Row As Integer)
ActiveSheet.CheckBoxes.Add(Cells(Row, "T").Left, Cells(Row, "T").Top, 72, 12.75).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "AA" & Row
.Display3DShading = False
End With
End Sub
Private Sub Delete_CheckBox(Row As Integer)
Dim cb As CheckBox
If cb.TopLeftCell.Address = (Row, "T") Then cb.Delete
End Sub
Naming the CheckBoxes will make it easier to maintain your code.
Private Sub Workbook_Open()
Const CheckBoxPrefix As String = "Sheet1TColumnCheckBox"
'declare a variable
Dim CheckBoxName As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
Dim r As Long
For r = 2 To 1000
CheckBoxName = CheckBoxPrefix & r
If Len(ws.Cells(r, 1)) > 0 Then
If Not WorksheetContainsCheckBox(CheckBoxName, ws) Then Add_CheckBox CheckBoxName, ws.Cells(r, 1), ws.Cells(r, "AA")
Else
If WorksheetContainsCheckBox(CheckBoxName, ws) Then ws.CheckBoxes(CheckBoxName).Delete
End If
Next
End Sub
Private Sub Add_CheckBox(CheckBoxName As String, Cell As Range, LinkedCell As Range)
With Cell.Worksheet.CheckBoxes.Add(Cell.Left, Cell.Top, 72, 12.75)
.Caption = ""
.Value = xlOff '
.LinkedCell = LinkedCell
.Display3DShading = False
.Name = CheckBoxName
End With
End Sub
Function WorksheetContainsCheckBox(CheckBoxName As String, ws As Worksheet)
Dim CheckBox As Object
On Error Resume Next
Set CheckBox = ws.CheckBoxes(CheckBoxName)
WorksheetContainsCheckBox = Err.Number = 0
On Error GoTo 0
End Function
Try something like this (put a checkbox "in" A1 but not C1)
Sub tester()
Debug.Print Delete_CheckBox([A1])
Debug.Print Delete_CheckBox([C1])
End Sub
'Return True if able to delete a checkbox from range `rng`
Private Function Delete_CheckBox(rng As Range) As Boolean
Dim cb As CheckBox
For Each cb In rng.Worksheet.CheckBoxes
If Not Application.Intersect(cb.TopLeftCell, rng) Is Nothing Then
Debug.Print "Deleting checkbox in " & cb.TopLeftCell.Address
cb.Delete
Delete_CheckBox = True
Exit For 'if only expecting one matched checkbox
End If
Next cb
End Function
I am trying to have a UserForm GUI so that we can add and subtract from inventory, I have got it so that I can select a worksheet and a row, but I am having trouble adding and subtracting part. Pretty new to VBA and I am not sure how to call that variable and modify it. Any help would be great!! Here is my code in the UserForm:
Option Explicit
Private Sub BTNadd_Click()
End Sub
Private Sub BTNDone_Click()
'This will save and close the GUI'
ThisWorkbook.Save
StgRmGUI.Hide
End Sub
Private Sub BTNrmv_Click()
End Sub
Private Sub ItmNmSlct_Change()
Dim actItm As String
End Sub
Private Sub ItmTypSlct_Change()
'This allows ItmTypSlct to show available wrkshts then will make item show in Item Name box'
With Worksheets(ItmTypSlct.Value)
ItmNmSlct.RowSource = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Address(, , , True)
End With
End Sub
Private Sub NumBox_Change()
Dim NewVal As Integer
NewVal = Val(NumBox.Text)
If NewVal >= SpBtnARNum.Min And _
NewVal <= SpBtnARNum.Max Then _
SpBtnARNum.Value = NewVal
End Sub
Private Sub SpBtnARNum_Change()
NumBox.Text = SpBtnARNum.Value
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
ItmTypSlct.AddItem ws.Name
End If
Next ws
End Sub
An simple example of updating the column B value by the amount in NumBox
Private Sub BTNadd_Click()
Dim r As Long, cell As Range
With ItmNmSlct
r = .ListIndex
If r < 0 Then Exit Sub
' select quatity cell and increment value
Set cell = Range(.RowSource).Cells(r + 1, 2)
cell.Value = cell.Value + NumBox.Value
End With
End Sub
Can anyone help me with a solution or a different method for this? I would like to edit the filtered listbox
I'm trying to get a listbox that is able to display my sheet1 and be able to filter all the blanks/not found in column A. I also want to be able to edit the listbox aswell
I would like my userform2 listbox to display the sheet1 information.
There will also be a checkbox which will filter the listbox to show “not found” or blank lines.
If i double click the selected item on the listbox i would like to edit the information
for userform2
Private Sub ListBox2_Click()
TextBox1.Enabled = True
TextBox1.Value = ListBox2.Value
End Sub
Private Sub TextBox1_Change()
Dim rCell As Range
With ListBox2
Set rCell = Range(.RowSource).Resize(1).Offset(.ListIndex)
rCell.Value = TextBox1.Value
End With
End Sub
Private Sub CheckBox1_Click()
OptimizedMode True
If userform2.CheckBox1.Value = True Then
Worksheets("Table").Range("A1").AutoFilter Field:=1, Criteria1:="Not Found", Operator:=xlOr, Criteria2:="="
userform2.ListBox2.RowSource = vbNullString
userform2.ListBox2.ColumnHeads = False
Dim rng As Range
Dim Cel1 As Range
Dim LR As Long
Dim ws As Worksheet
Set ws = Sheets("Table")
With ws
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LR).SpecialCells(xlCellTypeVisible)
With userform2.ListBox2
.ColumnCount = 1
For Each Cel1 In rng
.AddItem CStr(Cel1.Value)
.List(.ListCount - 1, 1) = Cel1.Offset(0, 1).Value
Next Cel1
End With
End With
End If
If CheckBox1.Value = False Then
With userform2.ListBox2
.RowSource = "Table!A2:A1048576"
End With
End If
OptimizedMode False
End Sub
I've re-designed my code and I believe this will achieve what you are after.
NOTE: This code uses all default object names. You will need to modify it to target the names for your workbook, sheet, useform, controls etc, if you wish to implement into your project.
In designing this answer I used the following:
A new blank Workbook with 1 new Worksheet
A new UserForm (captioned "ListBox Editor") with 1 ListBox that has 2 columns (ColumnCount = 2) and 1 CheckBox (captioned "Show Blanks").
The sample data I used was in Range("A1:A10") filling only odd numbers from row 1. This allows testing for including/excluding blank/empty rows. Screenshots of the Worksheet and UserForm below.
Worksheet data:
UserForms both with and without blanks in the listbox:
All code is written in the code behind module for the UserForm
Most can be written into any other module with calls made to the subs/functions from the UserForm/ListBox events if you'd prefer not to have the working code in the UserForm module.
Code blocks with explanations below (full code block at the end for copy/paste):
Option Explicit
Option Explicit should be included at the top of each and every code module you use. It forces explicit declaration of all variables which helps significantly in avoiding typo's in your code etc.
Private Sub PopulateListBox(ByVal IncludeBlanks As Boolean)
Dim TargetCell As Range
Dim TargetWorksheet As Worksheet
Set TargetWorksheet = ThisWorkbook.Sheets("Sheet1")
With UserForm1.ListBox1
.Clear
For Each TargetCell In TargetWorksheet.Range("A1:A10")
If Not IncludeBlanks Then
If Not TargetCell.Value = "" Then
.AddItem TargetCell.Value
.List(.ListCount - 1, 1) = TargetCell.Row
End If
ElseIf IncludeBlanks Then
.AddItem TargetCell.Value
.List(.ListCount - 1, 1) = TargetCell.Row
End If
Next TargetCell
.ColumnWidths = ";0" 'Hides listbox column that holds row number
End With
End Sub
PopulateListBox is a subroutine I wrote to handle population of the items in the ListBox. It first clears the list, allowing each population of the listbox to be 'refreshed' data. Then it iterates through each TargetCell of the defined Range. If IncludeBlanks is True it has no conditions to meet and adds each cell value into the list, if IncludeBlanks is False it will only add the cell value to the list if the value is not "".
Private Sub CheckBox1_Click()
If Me.CheckBox1.Value = False Then
PopulateListBox False
ElseIf Me.CheckBox1.Value = True Then
PopulateListBox True
End If
End Sub
This _Click event simply updates the ListBox list based on if the CheckBox is checked or not. The CheckBox represents if you are including blanks/empty cells or not so it passes True or False respective to it's Value, to the IncludeBlanks argument in PopulateListBox.
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim NewValue As Variant
Dim TargetWorksheet As Worksheet
Set TargetWorksheet = ThisWorkbook.Sheets("Sheet1")
NewValue = InputBox("What is the new value to replace " & UserForm1.ListBox1 & "?")
If Not StrPtr(NewValue) = 0 Then 'Check user did NOT click cancel or [X]
With ListBox1
If NewValue = "" Then NewValue = vbNullString
TargetWorksheet.Cells(.List(.ListIndex, 1), 1).Value = NewValue
.AddItem NewValue, .ListIndex
.RemoveItem .ListIndex
End With
End If
End Sub
The _DblClick Event triggers the code when a list item is double clicked. This code first opens an InputBox to allow the user to enter a new value for the selected listbox item. When the user clicks OK or hit's Enter, the new value is first written to the Cell that the original value came from, then the new value is added as a new list item and finally the previous value is removed. If the user clicks [X] or 'Cancel' the code does nothing.
Private Sub UserForm_Initialize()
PopulateListBox False
End Sub
Much the same as the Checkbox_Change code, this simply populates the ListBox when the UserForm is first initialized. It's written to exclude blanks, specified by False for the IncludeBlanks argument.
Put it all together and you have:
Option Explicit
Private Sub CheckBox1_Click()
If Me.CheckBox1.Value = False Then
PopulateListBox False
ElseIf Me.CheckBox1.Value = True Then
PopulateListBox True
End If
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim NewValue As Variant
Dim TargetWorksheet As Worksheet
Set TargetWorksheet = ThisWorkbook.Sheets("Sheet1")
NewValue = InputBox("What is the new value to replace " & UserForm1.ListBox1 & "?")
If Not StrPtr(NewValue) = 0 Then 'Check user did NOT click cancel or [X]
With ListBox1
If NewValue = "" Then NewValue = vbNullString
TargetWorksheet.Cells(.List(.ListIndex, 1), 1).Value = NewValue
.AddItem NewValue, .ListIndex
.RemoveItem .ListIndex
End With
End If
End Sub
Private Sub UserForm_Initialize()
PopulateListBox False
End Sub
Private Sub PopulateListBox(ByVal IncludeBlanks As Boolean)
Dim TargetCell As Range
Dim TargetWorksheet As Worksheet
Set TargetWorksheet = ThisWorkbook.Sheets("Sheet1")
With UserForm1.ListBox1
.Clear
For Each TargetCell In Range("A1:A10")
If Not IncludeBlanks Then
If Not TargetCell.Value = "" Then
.AddItem TargetCell.Value
.List(.ListCount - 1, 1) = TargetCell.Row
End If
ElseIf IncludeBlanks Then
.AddItem TargetCell.Value
.List(.ListCount - 1, 1) = TargetCell.Row
End If
Next TargetCell
.ColumnWidths = ";0"
End With
End Sub
I'm trying to move to first cell of next row of column "A" in excel whenever enter key is pressed in Column "H". My code so far is below;
Private Sub move_to_next_row(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
ActiveCell.Offset(1, -7).Activate
End If
End Sub
There is no KeyDown event or something similar for worksheets. You can only check if a cell in column H was changed and then move to the first column in the next row.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Columns("H")) Is Nothing Then
Me.Cells(Target.Row + 1, "A").Select
End If
End Sub
Not For Points
Another way in case you want to trap the "Enter" key in Col H (irrespective of whether user made a change or not in column H)
Credits:
#Tom for Application.OnKey
#AsUsual for Worksheet_SelectionChange
Place this in the worksheet code area
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wsName As String
wsName = ActiveSheet.Name
If ActiveCell.Column = 8 Then Application.OnKey "{Enter}", _
"'MoveCursor" & Chr(34) & wsName & Chr(34) & "'"
End Sub
Place this in the module.
Option Explicit
Sub MoveCursor(wsN As String)
If ActiveWorkbook.Name <> ThisWorkbook.Name Then GoTo CleanExit
If ActiveSheet.Name <> wsN Then GoTo CleanExit
Cells(ActiveCell.Row + 1, 1).Select
CleanExit:
'<~~ Reset the key to avoid undesirable sideeffects!
Application.OnKey "{Enter}"
End Sub
Try this (also gets triggered by the down arrow)
Option Explicit
Private col As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If .Column = 8 And col = 8 Then
Cells(.Row, 1).Select
col = 0
Exit Sub
End If
col = .Column
End With
End Sub
In your ThisWorkbook Object place the following
Private Sub Workbook_Open()
Application.OnKey "~", "move_to_next_row"
End Sub
And then run using F5
Then in a normal module place
Sub move_to_next_row()
Dim SelectRng As Range
On Error Resume Next
If ActiveCell.Column = 8 Then
Set SelectRng = ActiveCell.Offset(1, -7)
Else
If Application.MoveAfterReturn Then
Select Case Application.MoveAfterReturnDirection
Case xlToLeft
Set SelectRng = ActiveCell.Offset(0, -1)
Case xlToRight
Set SelectRng = ActiveCell.Offset(0, 1)
Case xlUp
Set SelectRng = ActiveCell.Offset(-1, 0)
Case xlDown
Set SelectRng = ActiveCell.Offset(1, 0)
End Select
End If
End If
On Error GoTo 0
If Not SelectRng Is Nothing Then
SelectRng.Activate
End If
End Sub
Whenever you press the enter key move_to_next_row will be called. If the ActiveCell is in column H it will move the ActiveCell to Column A
I am working on a customer complaint database. I want to implement a userform for data entry.
I have a button to clear the userform. It clears the entire form except for ComboBox2 that has results which are dependent on the selection from ComboBox1.
I get a 1004 run-time error based which calls back to the Match function I've used for ComboBox2.
Private Sub CommandButton2_Click()
Clear_Form
End Sub
Sub Clear_Form()
Me.ComboBox2.Clear
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ComboBox"
ctl.ListIndex = -1
End Select
Next ctl
End Sub
Private Sub UserForm_Activate()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Customer")
Dim i As Integer
Me.ComboBox1.Clear
For i = 1 To Application.WorksheetFunction.CountA(sh.Range("1:1"))
Me.ComboBox1.AddItem sh.Cells(1, i).Value
Next i
End Sub
Private Sub ComboBox1_Change()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Customer")
Dim i As Integer
Dim n As Integer
n = Application.WorksheetFunction.Match(Me.ComboBox1.Value, sh.Range("1:1"), 0)
Me.ComboBox2.Clear
For i = 2 To Application.WorksheetFunction.CountA(sh.Cells(1, n).EntireColumn)
Me.ComboBox2.AddItem sh.Cells(i, n).Value
Next i
End Sub
You will get an error because Clear_Form clears the combobox which in turn calls the _Change event and the Match fails because there is no value in combobox. Simply add one line to the _Change event.
Private Sub ComboBox1_Change()
If ComboBox1.ListIndex = -1 Then Exit Sub '<~~ ADD THIS
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Customer")
Dim i As Integer
Dim n As Integer
n = Application.WorksheetFunction.Match(Me.ComboBox1.Value, sh.Range("1:1"), 0)
Me.ComboBox2.Clear
For i = 2 To Application.WorksheetFunction.CountA(sh.Cells(1, n).EntireColumn)
Me.ComboBox2.AddItem sh.Cells(i, n).Value
Next i
End Sub