I already have a barcode scanner VBA function, that recognizes the barcode number, but the problem I have is that I have to click enter every time, is there any way to do it automatically and store the count in a certain column? Currently it works if I enter the same value stored in column B, it will count the records in column C, but I want to avoid hitting enter every time
This is what I got so far
Private Sub btnAdd_Click()
Dim TargetCell As Range
If WorksheetFunction.CountIf(Sheets("Sheet1").Columns(2), TextBox1.Value) = 1 Then
Set TargetCell = Sheets("Sheet1").Columns(2).Find(TextBox1.Value, , xlValues, xlWhole).Offset(0, 1)
TargetCell.Value = TargetCell.Value + 1
Else
MsgBox "Code not found"
End If
Me.Hide
End Sub
It's hard to say what you have. For example, who presses the button? Or, does your scanner enter a return. I think the code below should work under any circumstances. Please try it.
Private Sub TextBox1_Change()
Dim TargetCell As Range
Dim Qty As Long
With TextBox1
If Len(.Value) = 3 Then
Set TargetCell = Worksheets("Sheet1").Columns(2) _
.Find(.Value, , xlValues, xlWhole)
If TargetCell Is Nothing Then
MsgBox """" & .Value & """ Code not found"
Else
With TargetCell.Offset(0, 1)
Qty = .Value + 1
.Value = Qty
End With
Application.EnableEvents = False
TextBox1.Value = "Count = " & Qty
Application.EnableEvents = True
End If
.SelStart = 0
.SelLength = Len(.Value)
End If
End With
End Sub
I think you have a user form and in this form you have a text box called TextBox1. If so, the code should be in the user form's code module. If you have a text box in your worksheet paste the code to the code module of the sheet on which the text box resides.
Now, you need to adjust this line of code If Len(.Value) = 3 Then to determine when to process the data. This is because the Change event will occur whenever even a single character is entered. I tested with 3 characters. Change the number to a value equal to the length of the numbers you scan in. In theory that still leaves the CR hanging which your scanner might also send. If that causes a problem experiment with >= in place of the = in my code.
The code will add the scan to the existing quantity, just as you had it, and indicate the new total in the text box, in case you are interested. You might replace this with "OK". The code will select the text it enters. Therefore when you enter something else, such as a new scan, it will be over-written without extra clicks being required.
Related
I have tried a writing the code to set the limit of the textbox means if somebody enters the value 8 and if the limit in the code is set to the 10 then it should give message that pl. increase the entered value but adding to this its value of the limit also gets changed as per the value getting changed in the combo box means i have list of 5 to 7 numbers and there respective list if somebody selects the specific limit then the program should consider that adjacent cell value as respectively as shown in the image
For Eg: If someone selects the number 4456 then the minimum value of entering in the textbox is more than 50 same as if someone selects the 5566 number then minimum value entering in the textbox is more than 150 respectively if someone enters the value below that then it should show message that pl. increase the value with showing that minimum value requirement is 50 for 4456 eg.
Pl. help in getting solution of this
Any positive response are welcomed.
Pl. find the images of the userform and the sheet layout containing value in the attached document.
Private Sub ComboBox1_Change()
Dim t As Long, LastRow As Long, ws As Worksheet
Set ws = Sheets("Sheet1")
LastRow = ws.Range("H" & Rows.Count).End(xlUp).Row
For t = 2 To LastRow
If Val(Me.ComboBox1.Value) = ws.Cells(t, "H").Value Then
Me.TextBox1 = ws.Cells(t, "I").Value
If Val(Me.ComboBox1.Value) = ws.Cells(t, "H").Value Then
If Val(Me.TextBox2.Value) < ws.Cells(t, "J").Value Then
MsgBox ("Has to be greater than")
End If
End If
End If
Next t
End Sub
[User form Image the limit of value should be given to second textbox][1]
[Limits value ][2]
Regards,
Shubham Mehta
I think the best form here is to create a function which can save and return all of those number combinations. Like so:
Function CurrentMinimumValue() As Long
'Manually type in all the pairs of selected numbers and the corresponding minimum values
Select Case Me.ComboBox1.Value
Case 10
CurrentMinimumValue = 5
Case 20
CurrentMinimumValue = 15
Case 4456
CurrentMinimumValue = 50
Case 5566
CurrentMinimumValue = 150
End Select
End Function
Which can be used like:
Sub test()
Me.Combobox1.Value = 4456
MsgBox "The current minimum value allowed is " & CurrentMinimumValue()
MsgBox "Is the entered value above the minimum? " & Me.TextBox2.Value > CurrentMinimumValue()
End Sub
The line you were asking about can be rewritten like:
If Val(Me.TextBox2.Value) < CurrentMinimumValue() Then
MsgBox "Has to be greater than " & CurrentMinimumValue()
As per your example, assume the textbox is named TextBox2, then the following code allows you to check the value entered and issue a message:
Private Sub TextBox2_AfterUpdate()
If Me.Value < ComboBox1.Value Then
MsgBox "Value must be larger than " & ComboBox1.Value
Button_OK.Enabled = False
Else
Button_OK.Enabled = True
End If
End Sub
You must place this function in the code section of your user form.
I have a drop down button and macro assigned to it. Upon selection of option from drop down the macro asks user whether he/she wants to make the change. If user selects yes code runs successfully. If user selects no the code ends. But the drop down selection changes to the new value which user selected. I want to reflect the old selection before user opted not to effect the change.
Here is how it works.
Step 1 - Proposal Origin is NA
Step 2 - User changes it to LA. But in the confirmation window opts "No".
Step 3 - Since in step 2 user selected "No" nothing happened. But the selection shows Proposal Origin as LA.
I want to keep it as NA when user selects "No" in conformation window.
Here is the code I have
Sub Dropdown6_BeiÄnderung()
'Dropbox Location
Dim Update As Integer
DropVal = Range("L18").Value
Update = MsgBox("You have selected " & Cells(18, 12) & " as Proposal Location. This will reset the Labor sheets. Do you want to continue?", vbYesNo, vbDefaultButton1)
If Update = vbYes Then
Worksheets("NA-Hours").Range("C8").Value = 0
Worksheets("LA-Hours").Range("C8").Value = 0
Worksheets("EU-Hours").Range("C8").Value = 0
Worksheets("MEA-Hours").Range("C8").Value = 0
Worksheets("AP-Hours").Range("C8").Value = 0
For i = 17 To 21
SName = Cells(i, 16).Value
If Cells(i, 17).Value = 1 Then
Worksheets(SName).Visible = True
Else: Worksheets(SName).Visible = False
End If
Next
Else
me.Drop Down 6.text = DropVal
End If
End Sub
Need help on the else part to reflect the earlier selection which is stored in variable DropVal.
Please, look at the next code example in order to understand how a Drop Down object value can be handled:
Sub handleDropDown()
Dim dd As DropDown, rngDL As Range, DropVal As String
Set dd = ActiveSheet.DropDowns("Drop Down 6")
Set rngDL = ActiveSheet.Range(dd.ListFillRange)
DropVal = "Test" 'use here what you need
Debug.Print dd.value 'it returns the index of the selected item in ListFillRange range
Debug.Print rngDL(dd.value) 'it returns the drop down value
rngDL.cells(dd.value) = DropVal 'it set/change the drop down value, but changing the cell in the range
End Sub
What I tried showing is to change the drop down object value. I must confess I am not sure that I understand what "to reverse the drop down selection" should mean...
The drop down value can be changed only if DropVal is part of the drop down ListFillRange and it was the previous selection. In such a case, the next approach should work.
Practically, you should implement the next code inside your Else part of the code:
Dim dd As DropDown, rngDL As Range, mtch As Long
Set dd = ActiveSheet.DropDowns("Drop Down 6")
Set rngDL = ActiveSheet.Range(dd.ListFillRange)
'If Range("L18").Value = "NA" the drop down value will become "NA"
mtch = Application.match(DropVal, rngDL, 0)' position/index of DropVal
If Not IsError(mtch) Then
dd.value = mtch
Else
MsgBox DropVal & " could not be found in " & rngDL.Address
End If
I will admit to being a terrible at code, and have always struggled with Macros... forgive my ignorance.
What I am working on building is a part number index that will create a new sequential number within a numerical series after a macro-button is pressed.
I'd like each button to scan between a range [i.e. 11-0000 (MIN) and 11-9999 (MAX)] and select the max value cell that exists. At that selection point insert an entire new row below with the next + 1 sequential number in the "B" column.
I have my button creating the table row as I would like, however I need help in defining the ".select(=Max(B:B))" and as I understand Max will also limit the # of line items it queries?
I have also been playing with .Range("B" & Rows.CountLarge) with little to no success.
Ideally the 11-**** button [as seen in the screen cap] should insert a sequential number below the highlighted row.
Maybe I'm way over my head, but any guidance even in approach or fundamental structure of the code would help be greatly appreciated!
Private Sub CommandButton1_Click()
Sheets("ENGINEERING-PART NUMBERS").Range("B" & Rows.CountLarge).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Insert Shift:=xlDown
ActiveCell.Value = "=ActiveCell + 1"
End Sub
Screen Cap of Spread Sheet
Perhaps there is a simpler solution that I've overlooked, but the below will work.
Insert a module into your workbook and add this code:
Public Sub AddNextPartNumber(ByVal FirstCellInColumn As Range, Optional ByVal PartMask As Variant = "")
Dim Temp As Variant, x As Long, MaxValueFound(1 To 2) As Variant
'Some error checking
If PartMask = "" Then
MsgBox "No part mask supplied", vbCritical
Exit Sub
ElseIf Not PartMask Like "*[#]" Then
MsgBox "Invalid part mask supplied; must end in ""#"".", vbCritical
Exit Sub
ElseIf PartMask Like "*[#]*[!#]*[#]" Then
MsgBox "Invalid part mask supplied; ""#"" must be continuous only.", vbCritical
Exit Sub
End If
'Get the column of data into an array
With FirstCellInColumn.Parent
Temp = .Range(FirstCellInColumn, .Cells(.Rows.Count, FirstCellInColumn.Column).End(xlUp))
End With
'Search through the array and find the largest matching value
For x = 1 To UBound(Temp, 1)
If Temp(x, 1) Like PartMask Then
If MaxValueFound(1) < Temp(x, 1) Then
MaxValueFound(1) = Temp(x, 1)
MaxValueFound(2) = x
End If
End If
Next x
'Output new part number
If MaxValueFound(2) = 0 Then
'This part mask doesn't exist, enter one with 0's at the end of the list
With FirstCellInColumn.Offset(x - 1, 0)
.Value = Replace(PartMask, "#", 0)
.Select
End With
Else
'Get the length of the number to output
Dim NumberMask As String, NumFormatLength As Long
NumFormatLength = Len(PartMask) - Len(Replace(PartMask, "#", ""))
NumberMask = String(NumFormatLength, "#")
'Determine the new part number
MaxValueFound(1) = Replace(MaxValueFound(1), Replace(PartMask, NumberMask, ""), "")
MaxValueFound(1) = Replace(PartMask, NumberMask, "") & Format((MaxValueFound(1) * 1) + 1, String(NumFormatLength, "0"))
'Insert row, add new part number and select new cell
FirstCellInColumn.Offset(MaxValueFound(2), 0).EntireRow.Insert
With FirstCellInColumn.Offset(MaxValueFound(2), 0)
.Value = MaxValueFound(1)
.Select
End With
End If
End Sub
Then, for each button, you write the code like this:
Private Sub CommandButton1_Click()
'this is the code for the [ADD 11-****] button
AddNextPartNumber Me.Range("B16"), "11-####"
End Sub
Private Sub CommandButton2_Click()
'this is the code for the [ADD 22-****] button
AddNextPartNumber Me.Range("B16"), "22-####"
End Sub
This has been written assuming that inserting a new row onto your sheet won't affect other data and that adding new data to the bottom of the table without inserting a row also won't affect other data.
Assuming you're working with a table, by default it should auto-resize to include new data added to the last row.
Good luck learning the ropes. Hopefully my comments help you understand how what I wrote works.
I am writing a VBA code to go through a specified range or ranges, look for a keyword provided by the user at run-time, and grab the value in the cell offset from the cell with the keyword by an amount also provided by the user. For instance, if you wanted to look through A1:B10 for the word "Apple" and then grab the value in the cell to the right of every instance of "Apple", it can do that. Two weird things have been occurring for me. First and not so weird, when I run it and click the cancel button on the userform that only contains the single line "Unload Me", it throws an error saying it expected and End Sub statement, but it has one. I don't know why it is doing that. Weird thing number 2. Whenever I click and move the cursor to the end of the file after the Cancel_Click() sub, my excel crashes and closes. Every. Single. Time. And it is weird that it does that just from me clicking. It also sometimes happens when I click around the Cancel_Click() sub or hit enter around there too. Just simply from clicking. I don't get it. Any ideas? Code contained in the userform is below. Fyi, the user can input ranges like "A1:A10,E1:E10" separated by commas for multiple ranges. I don't think it is important for this question, but I thought I would add that since i don't know how to add the userform here, if you even can.
Private Sub Accept_Click()
'Searches for string input into the KeywordBox
'Grabs contents of the cell defined by the OffsetBox
'The range it searches through is defined by the RangeBox
Dim rawRange As String: rawRange = Me.RangeBox.Text
Dim rawOffset As String: rawOffset = Me.OffsetBox.Text
Dim Keyword As String: Keyword = Me.KeywordBox.Text
Dim numOfRanges As Integer: numOfRanges = 1
Dim Ranges() As Range
Dim commaLoc As Integer: commaLoc = -1
Dim tempRange As String: tempRange = rawRange
Dim offset As Integer
Dim values() As Double
Dim valCount As Integer: valCount = 0
'--------------------------------------------------------
'Set ranges
For i = 1 To Len(rawRange)
If (Mid(rawRange, i, 1) = ",") Then
numOfRanges = numOfRanges + 1
End If
Next
ReDim Ranges(numOfRanges) As Range
If (Not numOfRanges = 1) Then
For i = 1 To numOfRanges - 1
commaLoc = InStr(1, tempRange, ",")
Set Ranges(i) = Range(Left(tempRange, commaLoc - 1))
tempRange = Right(tempRange, Len(tempRange) - commaLoc)
Next
End If
Set Ranges(numOfRanges) = Range(tempRange)
'---------------------------------------------------------
'Set offset
If (IsNumeric(rawOffset)) Then
offset = CInt(rawOffset)
Else:
MsgBox ("Offset was not input as a number")
Exit Sub
End If
'----------------------------------------------------------
'Searches for keyword
For i = 1 To numOfRanges
For Each cell In Ranges(i)
If (cell.Value = Keyword) Then
valCount = valCount + 1
End If
Next
Next
ReDim values(valCount) As Double
valCount = 0
For i = 1 To numOfRanges
For Each cell In Ranges(i)
If (cell.Value = Keyword) Then
valCount = valCount + 1
values(valCount) = cell.offset(0, offset).Value
End If
Next
Next
For i = 1 To valCount
Range("I" & i).Value = values(i)
Next
Unload Me
End Sub
I've had similar, weird things happen to me. A good thing to try is to force the VBA project to reset, then save, exit, and restart Excel.
To force a project reset, add an Enum to the general section of one of your code modules. It doesn't matter what the enum is...make it something simple, like
Enum stoplight
Red
Yellow
Green
End Enum
As you do that, you'll get a message saying that it will reset your project. That's fine; let that happen. Then save your Excel workbook, exit excel completely, start it up again, reload your workbook, go into the VBA Editor, and delete the enum you added. Then recompile and see if things work better for you.
You put an "Exit Sub" in the set offset, this is probably causing your problem.
I was able to fix the issue by making a new workbook and copying everything over. It worked fine. I think the original was corrupted somehow. For those having the same issue, I think Rich Holton's answer would be worth a try in case you have more than just a few things to copy. Thanks everyone for you time and input on this!
I have a template that records hours worked by employees. Column 5 shows their contracted hours for the week and Column 14 shows additional hours they work. Part time staff (less than 37.5 hrs p/week) who work additional hours are paid a standard rate. However once they exceed 37.50 hours for the week they are paid at time and a half (this is recorded in a seperate column).
The code below picks up the total number of hours for the week (column 18) and if it exceeds 37.5 it will prompt the user to record some of the hours at time and a half. It's a failsafe way of ensuring people are paid correctly.
The code below works almost perfectly however if the contracted hours are less than 10, the message box pops up regardless. I think it is because I have a String data type for the hours in the code is as a String but I can't seem to get it to work with other data types. Any assistance would be much appreciated.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 14 Then
Dim I As Integer, CheckHours As Boolean
Dim MonthX As Worksheet
I = 6
CheckHours = False
Set MonthX = ThisWorkbook.ActiveSheet
Dim FT As String
FT = 37.5
Application.ScreenUpdating = False
'Use the Employee Number column to perform the check
Do While MonthX.Cells(I, 3) <> ""
'Declare variables
Dim ContractHours As String
Dim HoursPaid As String
Dim TotalHours As String
ContractHours = MonthX.Cells(I, 5)
HoursPaid = MonthX.Cells(I, 14)
TotalHours= MonthX.Cells(I, 18)
'If the contract hours plus the additional hours are greater than 37.50 then display warning
If TotalHours > FT Then
MsgBox "WARNING: Check the additional hours entered for " & _
MonthX.Cells(I, 2).Value & " " & MonthX.Cells(I, 1).Value & _
" as they will need to be split between Additional Basic and Overtime." & _
vbNewLine & vbNewLine & _
"Please refer to the Additional Hours Guidelines tab for more information.", vbOKOnly, "Please Check"
CheckHours = True
End If
I = I + 1
Loop
'Cancel boolean
If CheckHours = True Then
Cancel = True
End If
Application.ScreenUpdating = True
End If
End Sub
I don't know if your logic is right, but here's a rewrite that does the same thing as your code. There's a lot of extra stuff in your code that doesn't seem to have a purpose, so I removed it.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim dTotalHours As Double
Dim aMsg(1 To 5) As String
Const dFULLTIME As Double = 37.5
i = 6
If Target.Column = 14 Then
Do While Len(Me.Cells(i, 3).Value) > 0
dTotalHours = Me.Cells(i, 18).Value
If dTotalHours > dFULLTIME Then
aMsg(1) = "WARNING: Check the additional hours entered for"
aMsg(2) = Me.Cells(i, 2).Value
aMsg(3) = Me.Cells(i, 3).Value
aMsg(4) = "as they will need to be split between Additional Basic and Overtime." & vbNewLine & vbNewLine
aMsg(5) = "Please refer to the Additional Hours Guidelines tab for more information."
MsgBox Join(aMsg, Space(1)), vbOKOnly, "Please Check"
End If
i = i + 1
Loop
End If
End Sub
Some notes
Excel stores numeric cell values as Doubles. If you're reading a number from a cell, there's really no reason to use anything but a Double.
When you're in the sheet's class module (where the events are), you can use the Me keyword to refer to the sheet. You refer to Activesheet, but what you really want is the sheet where the selection change occurred. They happen to be the same in this case, but for other events they may not be.
It's faster to check the length of a string rather than to check if <>"".
Your FT variable never changes making it not variable at all. A constant may be a better choice.
I use an array to store all the elements of a long message, then use Join to make the final string. Easier to read and maintain.
I'm a keyboard guy, so this hits closer to home for me that most, but a message box every time the selection changes? That means that if I attempt to use the arrow keys to get to the cell where I will fix the error, I will get constant message boxes. Brutal. Maybe the _Change event or _BeforeSave event are worth consideration.
Try declaring as a 'single' instead of a 'String'
We were told to declare decimal numbers as singles when at uni. It may solve your issue.
Or another thing I have notice but don't know if it will affect it, you don't have an ELSE with your IF statement
The following code may need a bit of tweaking, but it should come close to what you need. It implements several of the suggestions in the comments to your question. The source of your difficulty was the use of string variables to deal with numeric values.
I've declared FT, ContractHours, HoursPaid, and SumHours as Single variables, and Cancel as a Boolean (although you don't use it in the subroutine).
You can set "Option Explicit" - which requires that variables be declared - as the default for your code by choosing Tools/Options from the menu bar of the VBA editor and then check-marking the "Require Variable Declaration" option on the Editor tab.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer, CheckHours As Boolean, Cancel As Boolean
Dim MonthX As Worksheet
Dim FT As Single
Dim ContractHours As Single
Dim HoursPaid As Single
Dim SumHours As Single
Set MonthX = ThisWorkbook.ActiveSheet
i = 6
FT = 37.5
If Target.Column = 14 Then
Application.ScreenUpdating = False
'Use the Employee Number column to perform the check
Do While MonthX.Cells(i, 3).Value <> ""
'Assign variables
ContractHours = MonthX.Cells(i, 5).Value
HoursPaid = MonthX.Cells(i, 14).Value
SumHours = MonthX.Cells(i, 18).Value
'When the contract hours plus the additional hours are greater than 37.50
' display warning
If SumHours > FT Then
MsgBox "WARNING: Check the additional hours entered for " & _
MonthX.Cells(i, 2).Value & " " & MonthX.Cells(i, 1).Value & _
" as they will need to be split between Additional Basic and Overtime." & _
vbNewLine & vbNewLine & _
"Please refer to the Additional Hours Guidelines tab for more information.", vbOKOnly, "Please Check"
CheckHours = True
End If
i = i + 1
Loop
'Cancel boolean
If CheckHours = True Then
Cancel = True
End If
Application.ScreenUpdating = True
End If
End Sub