Excel and Visual Basic Barcode In/Out checkout system - excel

I'm using visual basic to create a checkout system in an excel sheet. The sheet will be filled with information for a project, each of the projects requires that we send out a kit. This excel sheet will allow for a barcode to be scanned, when this happens, it checks for puts an "out" time. When that barcode is scanned again it puts an "in" time. The issue I'm having is that if that barcode is scanned a third time, it will only update the out time.
How do I set it up where it will see that an "in" and "out" time have been recorded and thus go the next blank cell in the row and add the barcode + new "in" or "out" time. Any help would be greatly appreciated!
This is the code I am using.
Code for on the worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
Application.EnableEvents = False
Call inout
Application.EnableEvents = True
End If
End Sub
code for the macro
Sub inout()
Dim barcode As String
Dim rng As Range
Dim rownumber As Long
barcode = Worksheets("Sheet1").Cells(2, 2)
Set rng = Sheet1.Columns("a:a").Find(What:=barcode, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then
ActiveSheet.Columns("a:a").Find("").Select
ActiveCell.Value = barcode
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Date & " " & Time
ActiveCell.NumberFormat = "m/d/yyyy h:mm AM/PM"
Worksheets("Sheet1").Cells(2, 2) = ""
Else
rownumber = rng.Row
Worksheets("Sheet1").Cells(rownumber, 1).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Date & " " & Time
ActiveCell.NumberFormat = "m/d/yyyy h:mm AM/PM"
Worksheets("Sheet1").Cells(2, 2) = ""
End If
Worksheets("Sheet1").Cells(2, 2).Select
End Sub

All this goes in the worksheet code module:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
inout 'use of Call is deprecated
End If
End Sub
Sub inout()
Dim barcode As String
Dim rng As Range
Dim newRow As Boolean
barcode = Me.Cells(2, 2)
'find the *last* instance of `barcode` in ColA
Set rng = Me.Columns("A").Find(What:=barcode, after:=Me.Range("A1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
'figure out if we need to add a new row, or update an existing one
If rng Is Nothing Then
newRow = True 'no matching barcode
Else
'does the last match already have an "in" timestamp?
If Len(rng.Offset(0, 2).Value) > 0 Then newRow = True
End If
If newRow Then
Set rng = Me.Cells(Me.Rows.Count, "A").End(xlUp).Offset(1, 0)
rng.Value = barcode
SetTime rng.Offset(0, 1) 'new row, so set "out"
Else
SetTime rng.Offset(0, 2) 'existing row so set "in"
End If
Me.Cells(2, 2).Select
End Sub
'set cell numberformat and set value to current time
Sub SetTime(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub

Related

Worksheet_change shows date as FALSE

This is my workbook, so I have a code, I'm using a scanner to scan barcodes. When I scan a barcode it adds "1" to the qty(Column c), I also want to record the date in column F, almost everything works fine except it does not type the date, it types "FALSE". I tried with macro+if formula (if cellrange=1,=(now),""). This works but unfortunately I use the workbook in Shared Mode and you cannot use macros in Shared Mode and vba is my last solution.
I am a beginner in VBA.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Item As String
Dim SearchRange As Range
Dim rFound As Range
'Don't run the macro if:
'Target is not a single cell:
If Target.Cells.Count > 1 Then Exit Sub
'or Target belongs to the A1.CurrentRegion:
If Not Intersect(Target, Range("A1").CurrentRegion) Is Nothing Then Exit Sub
'Avoid the endless loop:
Application.EnableEvents = False
'Looks for matches from the here first:
Set SearchRange = Range("A1:A" & Range("A1").CurrentRegion.Rows.Count)
Item = Target.Value
'Clears the Target:
Target.Value = ""
If Application.WorksheetFunction.CountIf(SearchRange, Item) > 0 Then
'There's a match already:
Set rFound = Columns(1).Find(What:=Item, After:=Cells(1, 1) _
, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'Adds one to the Quantity:
rFound.Offset(0, 2).Value = rFound.Offset(0, 2).Value + 1
rFound.Offset(0, 5).Value = rFound.Offset(0, 5).Value2 = Now
Else
'Writes the value for the Barcode-list:
Range("A" & SearchRange.Rows.Count + 1).Value = Item
'Looks for the match from sheet "Inventory" column A
With Sheets("Inventory")
Set rFound = .Columns(1).Find(What:=Item, After:=.Cells(1, 1) _
, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
On Error GoTo 0
If Not rFound Is Nothing Then
'Writes the Product Name and puts 1 to the Quantity column:
Range("B" & SearchRange.Rows.Count + 1).Value = rFound.Offset(0, 1).Value
Range("C" & SearchRange.Rows.Count + 1).Value = 1
End If
End With
End If
'Enable the Events again:
Application.EnableEvents = True
End Sub
Le:
Private Sub Worksheet_change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("C:C"), Target)
xOffsetColumn = 3
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
Please replace this row:
rFound.Offset(0, 5).Value = rFound.Offset(0, 5).Value2 = Now
with this one:
rFound.Offset(0, 5).Value = Format(Now, "dd-mm-yyyy hh:mm:ss")
Then comment the line of the Worksheet_change:
codetwo Target
and do the same with all rows of Module module

How to show date in another column If cell value changes?

My worksheet looks like this
First code, example, cell a2 is "123" when I type somewhere in the sheet (example K2) "123" then text "123" matches to A2 and it adds "1" to the quantity column in this case C2.
Second code: I want, when in Qty Column(C2) some cell is filled with "1" then in Date Column(F), to show the date when Qty row was filled with "1". This code only works if I type manually "1" and not by searching the barcode with the first code.
Private Sub Worksheet_Change(ByVal target As Range)
FirstCode target
SecondCode target
End Sub
Private Sub FirstCode(ByVal target As Range)
Dim Item As String
Dim SearchRange As Range
Dim rFound As Range
'Don't run the macro if:
'Target is not a single cell:
If Target.Cells.Count > 1 Then Exit Sub
'or Target belongs to the A1.CurrentRegion:
If Not Intersect(Target, Range("A1").CurrentRegion) Is Nothing Then Exit Sub
'Avoid the endless loop:
Application.EnableEvents = False
'Looks for matches from the here first:
Set SearchRange = Range("A1:A" & Range("A1").CurrentRegion.Rows.Count)
Item = Target.Value
'Clears the Target:
Target.Value = ""
If Application.WorksheetFunction.CountIf(SearchRange, Item) > 0 Then
'There's a match already:
Set rFound = Columns(1).Find(What:=Item, After:=Cells(1, 1) _
, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'Adds one to the Quantity:
rFound.Offset(0, 2).Value = rFound.Offset(0, 2).Value + 1
Else
'Writes the value for the Barcode-list:
Range("A" & SearchRange.Rows.Count + 1).Value = Item
'Looks for the match from sheet "Inventory" column A
With Sheets("Inventory")
Set rFound = .Columns(1).Find(What:=Item, After:=.Cells(1, 1) _
, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows _
, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
On Error GoTo 0
If Not rFound Is Nothing Then
'Writes the Product Name and puts 1 to the Quantity column:
Range("B" & SearchRange.Rows.Count + 1).Value = rFound.Offset(0, 1).Value
Range("C" & SearchRange.Rows.Count + 1).Value = 1
End If
End With
End If
'Enable the Events again:
Application.EnableEvents = True
End Sub
Private Sub SecondCode(ByVal target As Range)
If Target.Column <> 3 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
With Target.Offset(0, 3)
.Value = Now
.NumberFormat = "DD/MM/YYYY"
End With
End Sub

Receiving an Error 91 "Object variable or With block variable not set" when using .Find(What:-

I am receiving an Error 91 "Object variable or With block variable not set" when using .Find(What:-.
I want to find the column index number in the "overview" sheet by seaching for the value in Cells(2,2) from the "dailysheet".
I get the error on lnCol = line. I think it something to do with the formatting or setting the "checkdate" variable.
Any help would be great appreciated!
Sub checkingdate_Click()
Dim overview As Worksheet
Dim dailysheet As Worksheet
Dim datecheck As Range
Dim checkdate As Date
Dim lnRow As Long
Dim lnCol As Long
Set overview = ThisWorkbook.Worksheets("overview")
Set dailysheet = ThisWorkbook.Worksheets("dailysheet")
Set datecheck = dailysheet.Cells(2, 2)
lnRow = 5
overview.Rows("5").EntireRow.Hidden = False 'Adjust potentially
With datecheck
.NumberFormat = "dd/mm/yyyy"
'.NumberFormat = "#"
End With
With overview.Rows("5")
.NumberFormat = "dd/mm/yyyy"
'.NumberFormat = "#"
End With
checkdate = dailysheet.Cells(2, 2).Value
MsgBox datecheck.Value
MsgBox checkdate
lnCol = overview.Cells(lnRow, 1).EntireRow.Find(What:=checkdate, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
MsgBox lnCol
'=====
' END
'=====
overview.Rows("5").EntireRow.Hidden = True 'Adjust potentially
With overview.Rows("5")
.NumberFormat = "dd"
End With
With overview.Columns("B:ABO")
.ColumnWidth = 4.57
End With
End Sub
EDIT: Found a solution by changing the variable checkdate to dailysheet.Cells(2,2).Formula rather than .Values and changed to LookIn:=xlFormulas rather than LookIn:=xlValues. I also changed the .NumberFormat of overview.Rows("5"), so that the dates became serial numbers, thereby becoming searchable from the serial number from "checkdate".
Edited portion of the code is below:
With overview.Rows("5")
'.NumberFormat = "dd/mm/yyyy"
.NumberFormat = "#"
End With
checkdate = dailysheet.Cells(2, 2).Formula
MsgBox datecheck.Value
MsgBox checkdate
lnCol = overview.Cells(lnRow, 1).EntireRow.Find(What:=checkdate, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Found a solution by changing the variable checkdate to dailysheet.Cells(2,2).Formula rather than .Values and changed to LookIn:=xlFormulas rather than LookIn:=xlValues. I also changed the .NumberFormat of overview.Rows("5"), so that the dates became serial numbers, thereby becoming searchable from the serial number from "checkdate".
Edited portion of the code is below:
With overview.Rows("5")
'.NumberFormat = "dd/mm/yyyy"
.NumberFormat = "#"
End With
checkdate = dailysheet.Cells(2, 2).Formula
MsgBox datecheck.Value
MsgBox checkdate
lnCol = overview.Cells(lnRow, 1).EntireRow.Find(What:=checkdate, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column

Paste text into Excel comment VBA

I cannot find or create VBA code to allow pasting copied text from one cell in another sheet(sheet2) into a previously created comment in another sheet(sheet1).
Here is the code I have successfully compiled thus far, and I am stuck on how to get the text found into the comment box.
Sub For_Reals()
'Add Comment
Sheets("Sheet1").Range("F2").AddComment
Range("F2").Comment.Visible = False
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
'Copy Value 4 cells to the right of found Value
Selection.Offset(0, 4).Copy
'Need Code to paste copied value in previously created comment
End Sub
Rather than copy and paste the cell value into the comment, you create the text at the same time as creating the comment box. If a comment box already exists an error is raised - so remove any comment boxes in that cell beforehand.
The VBA help gives this as an example:
Worksheets(1).Range("E5").AddComment "Current Sales"
So with this in mind, this code will do the trick:
Sub For_Reals()
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'Remove any existing comments, create comment and add text.
If Not Rng Is Nothing Then
Sheets("Sheet1").Range("F2").ClearComments
Sheets("Sheet1").Range("F2").AddComment Rng.Offset(0, 4).Value
Range("F2").Comment.Visible = True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub
Final code I ended up with is below. Added a loop to run through the column, and added a second reference to pull both the definition and description into the comment. Thank you Darren Bartrup-Cook for helping me out when I was stuck!
Sub Add_Comment_As_Def_Desc_Reference()
'Posted by Jeff Barrett 2015-04-10
Dim FindString1 As String
Dim Rng1 As Range
Dim sCommentText1 As String
Dim sCommentText2 As String
Dim str1 As String
Dim str2 As String
Dim cmmt As String
Dim i As Integer
str1 = "Definition: "
str2 = "Description: "
'Loop Code, must specify range for i based on # of FieldAlias
Sheets("Fields").Select
Range("F4").Select
For i = 4 To 59
'Find Definition & Description in NASDefs based on Value from FieldAlias
FindString1 = ActiveCell.Value
If Trim(FindString1) <> "" Then
With Sheets("NASDefs").Range("C:C")
Set Rng1 = .Find(What:=FindString1, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
End If
'Remove any existing comments, create comment and add text in FieldAlias
If Not Rng1 Is Nothing Then
ActiveCell.ClearComments
sCommentText1 = Rng1.Offset(0, 4).Value
sCommentText2 = Rng1.Offset(0, 5).Value
ActiveCell.AddComment.Text Text:=str1 & Chr(10) & Chr(10) & sCommentText1 & Chr(10) & Chr(10) & str2 & Chr(10) & Chr(10) & sCommentText2
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
'Format lines of text
With ActiveCell.Comment.Shape.TextFrame
.Characters.Font.ColorIndex = 5
End With
Else
MsgBox "Nothing found"
End If
'End Loop
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
'Resize Comment to fit text
'posted by Dana DeLouis 2000-09-16
Dim MyComments As Comment
Dim lArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 300
' An adjustment factor of 1.1 seems to work ok.
.Shape.Height = (lArea / 200) * 0.6
End If
End With
Next ' comment
End Sub

How can a macro search for another cell which have the same value, and then change the value's?

I want the macro to look for same value as in B2. And then copy the value from range D2:G2 to the found range. In this example D9:G9.
Thank you in advance :D.
I tried:
Sub Button1_Click()
Dim myRng1, myRng2 As Range, cell As Range
Set myRng1 = Range("A4:A1000")
Set myRng2 = Range("D2:G2")
myRng2.Select
Selection.Copy
For Each cell In myRng1
If Range("A2") = Range("A" & cell.Row) Then Range("D" & cell.Row).Select
ActiveSheet.Paste
Next cell
End Sub
Sub Find()
Dim Findcode As String
Dim Rng As Range
Range("A2:F2").Select
Selection.Copy
Findcode = Sheets("Sheet1").Range("a2").Value
If Trim(Findcode) <> "" Then
With Sheets("Sheet1").Range("A4:A60000")
Set Rng = .Find(What:=Findcode, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
ActiveSheet.Paste
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

Resources