I have a userform with a combobox on a sheet "PostHistory" that draws it's data from the "Staff" sheet. When you press Add on the userform it's suppose to locate the name on the Staff Sheet and replace the date next to the name. Occasionally, it will replace the date and the date next to the name below it. Using Excel 2016
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Sheets("Staff").Visible = True
Sheets("Engine").Visible = True
Dim TargetRow As Integer
Dim nameRange As Range
Set nameRange = Sheets("Staff").Range("C3:C200")
TargetRow = Sheets("Engine").Range("D3").Value
Sheets("PostHistory").Range("B3").EntireRow.Insert Shift:=xlDown
Sheets("PostHistory").Range("B3").Value = txt_date
Sheets("PostHistory").Range("C3").Value = cb_staff
Sheets("PostHistory").Range("D3").Value = txt_post
Sheets("PostHistory").Range("E3").Value = txt_notes
If (Augment.txt_date.Text) = "" Then
GoTo Skip1
ElseIf IsNull(Augment.txt_date.Value) = False Then
End If
For Each cell In nameRange.Cells
If cell.Text = [cb_staff] Then
cell.Offset(0, -1).Value = txt_date
End If
Next
Skip1:
Unload Augment
Sheets("Staff").Visible = False
Sheets("Engine").Visible = False
Sheets("List").Visible = False
Application.ScreenUpdating = True
Augment.Show
End Sub
To start: I didn't find the reason why your code should write more than once. But I believe the code below will not write anything twice.
Private Sub CommandButton7_Click()
' 209
Dim nameRange As Range
Dim Fnd As Range
Dim Ctls() As String
Dim i As Integer
Ctls = Split("txt_Date,cb_Staff,txt_Post,txt_Notes", ",")
If Len(txt_Date) Then
With Worksheets("Staff")
Set nameRange = .Range(.Cells(3, 3), .Cells(.Rows.Count, 3).End(xlUp))
End With
Set Fnd = nameRange.Find(cb_Staff.Value, , xlValues, xlWhole)
If Not Fnd Is Nothing Then Fnd.Offset(0, -1).Value = txt_Date.Value
End If
With Worksheets("PostHistory")
.Rows(3).EntireRow.Insert Shift:=xlDown
With .Rows(3)
For i = 0 To UBound(Ctls)
.Cells(3 + i).Value = Me.Controls(Ctls(i)).Value
Me.Controls(Ctls(i)).Value = ""
Next i
End With
End With
End Sub
In principle, you don't need to unhide a sheet in order to read from or write to it. Also, if the sheet to which you write is hidden, there is no point in stopping ScreenUpdating. Finally, I did like the way you found to clear all controls but believe that it will interfere with your management of the list in the combo box. Therefore I showed you another method above.
Oh, yes. I created a userform called Augment with one combo box, 3 text boxes and one CommandButton7. I hope that is what you also have.
Related
Looking for a little assistance with a code I'm attempting to right.
The Result should be that when a user clicks a button on a userform named "Btn_LaSearch" that all columns in a range E6:MB6 are hidden except for the column where the name in the range matches that in a combobox on the userform.
the code i have so far looks like this...
Private Sub Btn_LASearch_Click()
Range("A1").Select
ActiveCell.Value = Cbo_LocalList.Value
Dim rngFound As Range
Dim Target As String
If Target.Address(0, 0) = "A1" Then
Application.ScreenUpdating = False
With Range("E6:MB6")
.EntireColumn.Hidden = False
If Target <> "" Then
Set rngFound = .Cells.Find(Target, , , xlWhole, , xlNext, False)
If Not rngFound Is Nothing Then
.EntireColumn.Hidden = True
rngFound.EntireColumn.Hidden = False
End If
End If
End With
Application.ScreenUpdating = True
End If
End Sub
I keep getting a Compile Error: Invalid Qualifier and it highlights this row.
If Target.Address(0, 0) = "A1" Then
I'm still very much an amateur when it comes to VBA so all help is appreciated.
Kind Regards,
I'm not sure why you're pasting the name into A1, then using that on a search when you already have access to the name.
Try something like this:
Private Sub Btn_LASearch_Click()
Dim c as Range
Application.ScreenUpdating = False
For Each c In Range("E6:MB6")
c.EntireColumn.Hidden = Not (c.Value = Cbo_LocalList.Value)
Next
Application.ScreenUpdating = True
End Sub
I am trying to find out a way to update the count of the selected checkboxes in excel using VBA.
i.e as the user selects the checkbox, the count has to get updated across the relevant filed. For example, If I select first check box ABC/18-49. The count at the top for (18-49) should get updated to 3.
P.S: This is how I have created the checkboxes dynamically.
Sub Main()
Dim Rng As Range
Dim WorkRng As Range
Dim Ws As Worksheet
On Error Resume Next
Set Ws = ThisWorkbook.Sheets(1)
Ws.Range("A:A").Insert
Set WorkRng = Ws.Range("A2:A" & Ws.UsedRange.Rows.Count)
Application.ScreenUpdating = False
For Each Rng In WorkRng
With Ws.CheckBoxes.Add(Rng.Left, Rng.Top, Rng.Width, Rng.Height)
.Characters.Text = "Yes"
End With
Next
WorkRng.ClearContents
WorkRng.Select
Application.ScreenUpdating = True
End Sub
Try the next way, please:
Copy the next Subs in a standard module and run the first one. It will assign a specific macro to all check boxes from column A:A:
Sub AssingMacro()
Dim sh As Worksheet, s As Shape, chkB As CheckBox
Set sh = ActiveSheet
For Each s In sh.Shapes
If left(s.Name, 6) = "Check " And s.TopLeftCell.Column = 1 Then
s.OnAction = "CheckBoxesHeaven"
End If
Next
End Sub
Sub CheckBoxesHeaven()
Dim sh As Worksheet, chB As CheckBox
Set sh = ActiveSheet
Set chB = sh.CheckBoxes(Application.Caller)
If chB.Value = 1 Then
Debug.Print chB.TopLeftCell.Offset(0, 2).Value
If chB.TopLeftCell.Offset(0, 2).Value = "18-49" Then
sh.Range("C3").Value = sh.Range("C3").Value + 1
ElseIf chB.TopLeftCell.Offset(0, 2).Value = "50-64" Then
sh.Range("C1").Value = sh.Range("C1").Value + 1
Else
sh.Range("C2").Value = sh.Range("C2").Value + 1
End If
Else
If chB.TopLeftCell.Offset(0, 2).Value = "18-49" Then
sh.Range("C3").Value = sh.Range("C3").Value - 1
ElseIf chB.TopLeftCell.Offset(0, 2).Value = "50-64" Then
sh.Range("C1").Value = sh.Range("C1").Value - 1
Else
sh.Range("C2").Value = sh.Range("C2").Value - 1
End If
End If
End Sub
Assort the values in range "C1:C3" to match the appropriate check boxes value. In order to automatically do that, please use the next code:
Sub ResetCheckBoxesValues()
Dim sh As Worksheet, chkB As CheckBox, i As Long
Dim V50_64 As Long, V18_49 As Long, VLess18 As Long
Set sh = ActiveSheet
For Each chkB In sh.CheckBoxes
If chkB.TopLeftCell.Column = 1 Then
Select Case chkB.TopLeftCell.Offset(0, 2).Value
Case "50-64"
If chkB.Value = 1 Then V50_64 = V50_64 + 1
Case "18-49":
If chkB.Value = 1 Then V18_49 = V18_49 + 1
Case "<18":
If chkB.Value = 1 Then VLess18 = VLess18 + 1
End Select
End If
Next
sh.Range("C1:C3").Value = Application.Transpose(Array(V50_64, VLess18, V18_49))
End Sub
Start playing with check boxes selection. It will add a unit to the appropriate cell if checking and decrease it with a unit in case of unchecking.
Please, test it and send some feedback
It will not be "very" dynamic, make sure to click on a random Excel cell, to make the formula recalculate after updating the check on the checkbox.
But the formula works in Excel, with the checkboxes you have created:
Public Function CountCheckBoxes()
Dim chkBox As Shape
Dim counter As Long
With ThisWorkbook.Worksheets(1)
For Each chkBox In .Shapes
If InStr(1, chkBox.Name, "Check Box") Then
If .Shapes(chkBox.Name).OLEFormat.Object.Value = 1 Then
counter = counter + 1
End If
End If
Next chkBox
End With
CountCheckBoxes = counter
End Function
Probably you should think about a suitable workaround to avoid ThisWorkbook.Worksheets(1), depending on where the code is residing.
I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.
The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the routine early if there is an error
On Error GoTo EExit
'Manage Events
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Declare Variables
Dim rng_DropDown As Range
Dim rng_HideFormula As Range
Dim rng_Item As Range
'The reference the row hide macro will look for to know to hide the row
Const str_HideRef As String = "Hide"
'Define Variables
'The range that contains the week selector drop down
Set rng_DropDown = Range("rng_WeekSelector")
'The column that contains the formula which indicates if a row should
'be hidden c.2000 rows
Set rng_HideFormula = Range("rng_HideFormula")
'Working Code
'Exit sub early if the Month Selector was not changed
If Not Target.Address = rng_DropDown.Address Then GoTo EExit
'Otherwise unprotect the worksheet
wks_DailyPlanning.Unprotect (str_Password)
'For each cell in the hide formula column
For Each rng_Item In rng_HideFormula
With rng_Item
'If the cell says "hide"
If .Value2 = str_HideRef Then
'Hide the row
.EntireRow.Hidden = True
Else
'Otherwise show the row
.EntireRow.Hidden = False
End If
End With
'Cycle through each cell
Next rng_Item
EExit:
'Reprotect the sheet if the sheet is unprotected
If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)
'Clear Events
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.
Is it possible to create something like an array of .visible settings I can apply to the entire range at once?
I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.
Sub HideHiddenRows()
Dim dataRange As Range
Dim data As Variant
Set dataRange = Sheet1.Range("A13:A2019")
data = dataRange.Value
Dim rowOffset As Long
rowOffset = IIf(LBound(data, 1) = 0, 1, 0)
ApplicationPerformance Flag:=False
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
If data(i, 1) = "Hide" Then
dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
Else
dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
End If
Next i
ApplicationPerformance Flag:=True
End Sub
Public Sub ApplicationPerformance(ByVal Flag As Boolean)
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
End Sub
Another possibility:
Dim mergedRng As Range
'.......
rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
If rng_Item.Value2 = str_HideRef Then
If Not mergedRng Is Nothing Then
Set mergedRng = Application.Union(mergedRng, rng_Item)
Else
Set mergedRng = rng_Item
End If
End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing
'........
to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:
Sub HideHiddenRows()
Dim cl As Range, x As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In Range("A1", Cells(x, "A"))
If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
Next cl
Range(Join(dic.keys, ",")).EntireRow.Hidden = False
End Sub
demo:
I'm writing a small macro for searching and sorting barcodes.
The idea is that barcodes are scanned into cell C1, then the macro is suppose to count the amount of times the same code is scanned. If the barcode is not already in the list (column B:B) it should add the new barcode in the list (column B:B).
I've managed utilised the Find() syntax, however I can't manage to edit any cells with it. Only thing I am able to do is MsgBox " " Ive tried:
Range("a5").Value = 5
It doesn't work
This is the code I currently have:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("C1") = "" Then MsgBox "No input"
Dim barcodes As Range
Set barcodes = Range("B:B").Find(What:=Range("C1").Value, After:=Range("B2"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, MatchByte:=True, SearchFormat:=False)
If Not barcodes Is Nothing And Not Range("C1") = "" Then
MsgBox "Found"
End If
If barcodes Is Nothing And Not Range("C1") = "" Then
MsgBox "New product"
End If
End Sub
For MsgBox "Found" I want instead a code that counts the amount of times the same barcode has been scanned in the adjacent cell to the right.
And for Msgbox "New product" I want to write a part that adds the new code to the list in this case Column B:B
The the below will A) verify that you don't have a match (using IsError, which returns boolean) to determine if you need to add a value and start the scan count at 1, or B) if you need to find the previous entry (using Match()) and add to the counter:
If IsError(Application.Match(Cells(1,3).Value,Columns(2),0)) Then
lr = cells(rows.count,2).end(xlup).row
Cells(lr+1,2).Value = Cells(1,3).Value
Cells(lr+1,1).Value = 1
Else
r = Application.match(Cells(1,3).Value,Columns(2),0)
cells(r,1).value = cells(r,1).value + 1
End If
Edit1:
Updated column #s for second subroutine per comment from OP, while stripping out the first subroutine and rewording.
With this code you will need a sheet called "DataBase" where you will store each scan and later will be the source for example for a pivot table:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Barcode As String, i As Long, wsDB As Worksheet, LastRow As Long
Dim DictBarcodes As New Scripting.Dictionary 'You need to check the Microsoft Scripting Runtime reference for this to work
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wsDB = ThisWorkbook.Sheets("DataBase")
With Target
If .Range("C1") = vbNullString Then MsgBox "No input"
On Error Resume Next
'loop through all the barcodes and store them into a dictionary
For i = 1 To .Rows.Count
If .Cells(i, 2) = vbNullString Then Exit For 'skip the loop once a blank cell is found
DictBarcodes.Add .Cells(i, 1), i 'this will raise an error if there are duplicates
Next i
'If the value doesn't exist we add it to the list
If Not DictBarcodes.Exists(.Cells(1, 3)) Then
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Cells(LastRow, 2) = .Cells(1, 3)
End If
End With
'Either it exists or not, store it to the data base to keep tracking
With wsDB
.Cells(1, 1) = "Barcode"
.Cells(1, 2) = "Date Scan"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(LastRow, 1) = .Cells(1, 3)
.Cells(LastRow, 2) = Now
End With
'Finally the output on the adjacent cell
Target.Cells(1, 4) = Application.CountIf(wsDB.Range("A:A"), Target.Cells(1, 3))
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
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