Can't figure out problem with Excel VBA code - excel

I am fairly new to writing code in excel VBA. Most of this code is some I have tried to replicated based on what other people have wrote. The problem I am having is I have a quantity counter and when a barcode is scanned into the cell (A4) it will add the barcode to a new cell (Starts at C8 and goes down) and if this barcode is already scanned once and is scanned again it will add one to the quantity. Now I am trying to add a date and time next to it as a barcode is scanned. This works but has an issue I can't figure out. The barcode must be scanned twice for the date to appear in the proper cell. This is an issue because it raises the quantity up one more than it should. Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Address
Case "$A$4"
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count) _
.End(xlUp)).Find(Range("A4").Value)
With xitem.Offset(0, -1)
.Value = .Value + 1
.Offset(0, 1).Select
End With
With xitem.Offset(0, 1)
.Value = Date & " " & Time
.NumberFormat = "m/d/yyyy h:mm AM/PM"
End With
On Error GoTo 0
If xitem Is Nothing Then
With Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = Target.Value
.Offset(0, -1) = 1
End With
End If
Range("A4") = ""
Range("A4").Select
End If
Adds quantity
Case "$C$4"
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count).End(xlUp)) _
.Find(Range("C4").Value)
With xitem.Offset(0, -1)
.Value = .Value - 1
End With
If xitem Is Nothing Then MsgBox Target & " cannot be found " _
& "and cannot be removed."
Range("C4") = ""
Range("C4").Select
On Error GoTo 0
End If
Removes quantity (I am going to add an out time to this just trying to get the initial scan time in first)
Case "$E$4" 'find
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count).End(xlUp)) _
.Find(Range("E4").Value)
If xitem Is Nothing Then
MsgBox Target & " was not found."
Range("E4").Select
End If
Range("E4") = ""
xitem.Select
On Error GoTo 0
End If
End Select
End Sub
This is what I am using to take me directly to a barcode that has already been scanned.
Sorry if this post is badly formatted never posted before. Any and all help with this issue is appreciated. A photo of the spread sheet is also attached.

You are repeating some things within your code which you only need to do once, like the Find() for example.
Here's one alternative approach:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, -1)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, -1)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub

Related

VBA Trigger Worksheet Change with Copy/Paste

I am trying to use VBA to populate spreadsheet column G with an image file based on the value of column B on the same row of the sheet. If I manually enter the value into column B everything works great, however I have a long list and was hoping to copy/paste multiple values into column B. When I paste it seems like the worksheet change is not triggered and column H is not populated with images. The code I am using is below, any help would be greatly appreciated. Thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture And shp.TopLeftCell.Address = Target.Offset(0, 4).Address Then shp.Delete
Next
If Target.Value <> "" And Dir(ThisWorkbook.Path & "\" & Target.Value & ".jpg") = "" Then
'picture not there!
MsgBox Target.Value & " Doesn't exist!"
End If
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 5).Top
Selection.Left = Target.Offset(0, 5).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 5).Height
.Width = Target.Offset(0, 5).Width
End With
Target.Offset(1, 0).Select
son:
End Sub
When you paste multiple value the Target parameter becomes array of range you paste.
And it is also a array of 1 member if you paste only 1 row.
So, use For..Next loop to complete all row you were paste. And change all Target to Target(i) and change some code as below.
For i = 1 To Target.Rows.Count
If Target(i).Value <> "" And Dir(ThisWorkbook.Path & "\" & Target(i).Value & ".jpg") = "" Then
'picture not there!
MsgBox Target(i).Value & " Doesn't exist!"
Else
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target(i).Value & ".jpg").Select
Selection.Top = Target(i).Offset(0, 5).Top
Selection.Left = Target(i).Offset(0, 5).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target(i).Offset(0, 5).Height
.Width = Target(i).Offset(0, 5).Width
End With
End If
Next

excel "insert line" causing error with target.offset

I have this simple bit of code that automates some dates and stuff when adding line items to a sheet. It works well, but when I insert a line in to the spreadsheet [right-click the line name > insert] an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim plusWeek
plusWeek = Now() + 7
For Each cell In Target
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 And cell = "Closed" Then
Target.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
End If
If cell.Column = 13 And cell = "In-Progress" Then
Target.Offset(0, -2) = ""
End If
If cell.Column = 13 And cell = "Open" Then
Target.Offset(0, -2) = ""
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not IsEmpty(Target.Offset(0, 0)) Then
Target.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
Target.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
Target.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
End Sub
if I paste a line, add a line or delete a line, error 1004 occurs. The debugger highlights this line, but I can't understand where the error comes from.
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not
IsEmpty(Target.Offset(0, 0)) Then
Something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim plusWeek
plusWeek = Now() + 7
Set rng = Application.Intersect(Target, Me.Range("H:H,M:M"))
If rng Is Nothing Then Exit Sub
On Error GoTo haveError '<< make sure events don't get left turned off
Application.EnableEvents = False '<< turn events off
For Each cell In rng.Cells
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 Then
Select Case cell.Value
Case "Closed": cell.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
Case "In-Progress", "Open": cell.Offset(0, -2) = ""
End Select
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(cell.Offset(0, 1)) And Not IsEmpty(cell) Then
cell.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
cell.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
cell.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
haveError:
Application.EnableEvents = True
End Sub

Generate date stamp when data entered

I am trying to create a nonvolatile date stamp in Column A cells as entries are made in B, C and D cells in the same row.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
For i = 2 To 10000
If Cells(i, “B”).Value <> “” And _
Cells(i, “C”).Value <> “” And _
Cells(i, “D”).Value <> “” And _
Cells(i, “A”).Value = “” Then
Cells(i, "A").Value = Date & " " & Time
Cells(i, "A").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
Range("A:A").EntireColumn.AutoFit
End Sub
I made it go to 10000 for the simple fact I do not know how to tell it to go as long as entries are entered.
It appears that you want to receive a datestamp once columns B:D are filled and column A is still empty.
If you write values back to the worksheet, disable event handling and provide error control.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("B:D"), Target) Is Nothing Then
On Error GoTo exit_handler
Application.EnableEvents = False
Dim r As Range
For Each r In Intersect(Range("B:D"), Target).Rows
If Cells(r.Row, "B").Value <> vbNullString And Cells(r.Row, "C").Value <> vbNullString And _
Cells(r.Row, "D").Value <> vbNullString And Cells(r.Row, "A").Value = vbNullString Then
Cells(i, "A").Value = Now
Cells(i, "A").NumberFormat = "mm/dd/yyyy h:mm AM/PM"
End If
Next t
End If
exit_handler:
Application.EnableEvents = True
End Sub
Try this to get rid of the loop:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Target.Count = 1 And Target.Column > 1 And Target.Column < 5 Then
If Cells(Target.Row, "B").Value <> "" And Cells(Target.Row, "C").Value <> "" And Cells(Target.Row, "D").Value <> "" And Cells(Target.Row, "A").Value = "" Then
Cells(Target.Row, 1).Value = Now
Cells(Target.Row, 1).NumberFormat = "m/d/yyyy h:mm AM/PM"
Range("A:A").EntireColumn.AutoFit
End If
End If
End Sub
In short, when you make a change on column B C or D, it will check if All 3 for that Row are filled and then put the time stamp if it doesnt have one. Skipping the loop. If you are pasting data instead of typing it, it will not work, instead use the loop from Pawel's answer.

Calling a macro from another

I running a macro that pops up a message if the user inputs a value in column E having column D empty. therefore the user has to input value in D and then in E. once the user inputs a value in D, by Vlookup formula the sheet will display a number in column F.
The second macro should then check if value of column F is not equal to value input in column E, if not equal popup a message.
First part is working but not the second. any idea please. thanks
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Cells(Target.Row, 5).Address And Target.Value <> "" And Cells(Target.Row, 4).Value = "" Then
MsgBox "Input value in column D"
Cells(Target.Row, 4).Select
Target.Clear
End If
Call Macro2
End Sub
Sub Macro2()
If Target.Address = Sheets(1).Cells(Target.Row, 5).Address And Target.Value <> "" And Target.Value <> Sheets(1).Cells(Target.Row, 6).Value Then
MsgBox "E and F don't match"
End If
End Sub
If the second one is the problem, then pass the Target to it:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False '<--- Consider removing this line
If Target.Address = Cells(Target.Row, 5).Address _
And Target.Value <> "" _
And Cells(Target.Row, 4).Value = "" Then
MsgBox "Input value in column D"
Cells(Target.Row, 4).Select
Target.Clear
End If
Macro2 Target
Application.EnableEvents = True '<--- Consider removing this line
End Sub
Sub Macro2(Target As Range)
If IsError(Target) Then
MsgBox Target.Address & "is an error!"
ElseIf IsError(Sheets(1).Cells(Target.Row, 6)) Then
MsgBox Sheets(1).Cells(Target.Row, 6).Address & " is an error!"
ElseIf Target.Address = Sheets(1).Cells(Target.Row, 5).Address _
And Target.Value <> "" _
And Target.Value <> Sheets(1).Cells(Target.Row, 6).Value Then
MsgBox "E and F don't match"
End If
End Sub
However, it could be that Target.Clear is making a loop within the Worksheet_Change, because it changes the worksheet once again. Depending on whether this is ok or not ok, you may consider writing Application.EnableEvents = False and Application.EnableEvents = True at the start or at the end of the Sub.

How to automatically store row created date and update date (of any cell in a row) into separate cells?

I am trying to create a VBA code on a Excel sheet where I can automatically insert the created date (once data is being inserted in a row) and updated date (once any cell value of the row change from the previous value).
I tried the code below, I can get the created date but the not the update date.
I get this error
Type mismatch
on the line:
If Cells(Target.Row, i).Value <> PrevVal(Target.Row, i) Then
I guess the problem is that I don't know how to capture properly the previous value of a cell in order to compare it with the new value.
For reference: my table is like this:
Id Position1 Position2 DATE Created Date updated Data1 Data2 ....
Dim PrevVal As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGraceFully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Selection.Value
Else
PrevVal = Selection
End If
ExitGraceFully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("B:B"), Target) Is Nothing Or Not
Intersect(Range("C:C"), Target) Is Nothing Then
Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)
If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
Dim i As Integer
If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
For i = 2 To 50
If Cells(Target.Row, i).Value <> PrevVal(Target.Row, i) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next i
End If
End Sub
I finally corrected my code and now it's working well.
Dim PrevVal As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGraceFully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Target.Value
Else
PrevVal = Target
End If
ExitGraceFully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("B:C"), Target) Is Nothing Then
Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)
If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
If Not Intersect(Range("F:Z"), Target) Is Nothing Then
Application.EnableEvents = False
If (PrevVal <> "") And (Cells(Target.Row, Target.Column).Value <> PrevVal) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
Application.EnableEvents = True
End Sub
Thank you so much #userZZZ, this is exactly what I was looking for!
I adapted your code to my requirements and added another constraint to change the date also when the content of a cell is deleted. I noticed that the code only works for single cells, but not for multiple cells. I might work on that sometime, but for now this is sufficient.
Edit: I added the possibility to manipulate multiple cells at once and update the date for all the corresponding rows. It still doesn't work for copy/paste of multiple cells though. For that purpose, I added an error message. Alternatively, the copy/paste mode can simply be deactivated by adding "Application.CutCopyMode = False" right at the beginning of the first function.
Dim PrevVal As Variant
Dim Block_rows As Integer
Dim Date_column As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGracefully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Target.Value
Else
PrevVal = Target
End If
ExitGracefully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Date_column = 9
Block_rows = 8
On Error GoTo ErrorMessage
'Select and change single cell
If Not Intersect(Range("A:H"), Target) Is Nothing And Target.Row > Block_rows Then
Application.EnableEvents = False
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
'Update date if value changes or is deleted
If (Cells(Target.Row, Target.Column).Value <> PrevVal) Or _
(Cells(Target.Row, Target.Column).Value = 0 And PrevVal <> 0) Then
Cells(Target.Row, Date_column).Value = Date
Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
End If
'Select multiple cells, but only change single cells
ElseIf (Cells(Target.Row, Target.Column).Value <> PrevVal(Target.Row - Selection.Row + 1, Target.Column - Selection.Column + 1)) And _
(Cells(Target.Row, Target.Column).Value <> 0) Then
Cells(Target.Row, Date_column).Value = Date
Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
'Delete multiple cells at once
Else
For RCount = 0 To Target.Rows.Count - 1
For CCount = 0 To Target.Columns.Count - 1
'Blank rows
If (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) = 0) Then
'Delete cells or rows
ElseIf (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) <> 0) Then
Cells(Target.Row + RCount, Date_column).Value = Date
Cells(Target.Row + RCount, Date_column).NumberFormat = "dd-mmm-yyyy"
End If
Next CCount
Next RCount
End If
End If
Application.EnableEvents = True
Exit Sub
ErrorMessage:
MsgBox ("This function is not supported for the automatic update of the date.")
Resume Next
End Sub

Resources