QR-reader to Excel (with time stamp)

[Hedengren]

Hi!


A fellow on the internet posted some code that I am trying to use for my own project. The code controls how the input from a QR-reader is printed out in an Excel Spreadsheet.


The code is written so that when a QR-code is read it prints out the QR-code in column A and a time stamp is printed out in column C. When the same QR-code is read a second time it prints out another time stamp next to the previous one.


For my project, if the QR-code is scanned a second time I want the entire row that the QR-code and time stamp is on - to be deleted. I've tried altering the code but I'm having trouble with deleting the right row.


Does anyone have any advice on how to write the code so that this could be possible?


I'm glad for any help and advices.:)




This how it looks now when QR-codes are read and printed to the spreadsheet:




18042






This is the code:



Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A3000")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Dim lc As Long, fr As Long, n As Long, nr As Long
With Application
.EnableEvents = False
.ScreenUpdating = False
n = Application.CountIf(Columns(1), Cells(Target.Row, 1))
If n = 1 Then
lc = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
If lc = 1 Then
Cells(Target.Row, lc + 2) = Format(Now, "m/d/yyyy h:mm")
ElseIf lc > 2 Then
Cells(Target.Row, lc + 1) = Format(Now, "m/d/yyyy h:mm")
End If
Else
fr = 0
On Error Resume Next
fr = Application.Match(Cells(Target.Row, 1), Columns(1), 0)
On Error GoTo 0
If fr > 0 Then
lc = Cells(fr, Columns.Count).End(xlToLeft).Column
If lc = 1 Then
Cells(fr, lc + 2) = Format(Now, "m/d/yyyy h:mm")
ElseIf lc > 2 Then
Cells(fr, lc + 1) = Format(Now, "m/d/yyyy h:mm")
End If
Target.ClearContents
End If
End If
On Error Resume Next
Me.Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
nr = Me.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
Me.Cells(nr, 1).Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

[snb]

Do you want the row to be deleted or to be replaced ?

[Hedengren]

I want the entire row to be deleted, and the row below to be moved up.
So when the QR-code for Row 2 is scanned again, that row should be deleted and row 3 should be moved up and take its place.

[Kenneth Hobs]

I am not sure how that data gets added. Say you have the 3 data rows added. Would your qrreader insert a 4th data row which might be a duplicate of say A3? Would you then need row 3 deleted or the newest duplicate in row 5 deleted?

Basically, keep newest duplicate or delete it if it exsists?

[Hedengren]

I am not sure how that data gets added. Say you have the 3 data rows added. Would your qrreader insert a 4th data row which might be a duplicate of say A3? Would you then need row 3 deleted or the newest duplicate in row 5 deleted?

Basically, keep newest duplicate or delete it if it exsists?


Delete it if it already exist. For example, in the picture we can see that QR-reader has printed out MTU1374 on row 3. If that QR was to be read again, the entire row 3 should be deleted and row 4 should take its place(be moved up).

[Kenneth Hobs]

I am not sure what all you are doing.

I would use a range find. e.g.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range

Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
If Intersect(Target, r) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub

Application.EnableEvents = False
Application.ScreenUpdating = False

If WorksheetFunction.CountIf(r, Target) = 1 Then
'do your other stuff here...
Else 'Duplicates found
'Delete first duplicate row
r.Find(Target, after:=Target).EntireRow.Delete xlShiftUp
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[Hedengren]

I am not sure what all you are doing.

I would use a range find. e.g.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range

Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
If Intersect(Target, r) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub

Application.EnableEvents = False
Application.ScreenUpdating = False

If WorksheetFunction.CountIf(r, Target) = 1 Then
'do your other stuff here...
Else 'Duplicates found
'Delete first duplicate row
r.Find(Target, after:=Target).EntireRow.Delete xlShiftUp
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Thanks for the reply.

It now works like a charm. Thank you! :):clap: