Scan barcode to excel with date & time stamp in & out.

[qpywsqp]

Hi all. I have research around the internet and finally found out Macro able to solve my issue. But im totally not a programmer. Hopefully someone can help me on this.

I will scan QR Code with a scanner to cell A1 and wanted cell C1 to have date and time stamp for IN. When Scanner scan the same QR Code, D1 will have date and time stamp for out. If repeat third time scanning the same QR code after a few scanning, it will appear on next row. Which means A8 with the code and C8 with date and time stamp for IN again.

Is that possible to done with Macro?

 

[MadeFromMetal]

Thank you for your efforts, Hiker95!

 

[Ingolf]

Kadam18,

With the above quote in mind, make sure that in row 4, that the headings in range B4:D4, are copied all the way out to range AC4:AE4, like the below screenshot (not all columns are shown for brevity).

Excel 2007

	A	B	C	D	AC	AD	AE	AF
1	Name
2
3
4	Name	Time Out	Time In	Time (hh:mm:ss)	Time Out	Time In	Time (hh:mm:ss)

<tbody>
</tbody>

Sheet1​

Private Sub Worksheet_Change(ByVal Target As Range)
' hiker95, 11/09/2016, ME672492
Dim na As Range, rng As Range, nr As Long, nc As Long
If Intersect(Target, Range("A2")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
With Application
  .EnableEvents = False
  .ScreenUpdating = False
  Set rng = .Range("A4", .Cells(.Rows.Count, "A").End(xlUp))
  Set na = rng.Find(Target.Value, LookAt:=xlWhole)
  If na Is Nothing Then
    nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Me.Cells(nr, 1).Value = Target.Value
    With Me.Cells(nr, 2)
      .Value = Now()
      .NumberFormat = "mm.dd.yyyy hh:mm:ss"
    End With
  ElseIf Not na Is Nothing Then
    nc = Me.Cells(na.Row, .Columns.Count).End(xlToLeft).Column + 1
    With Me.Cells(na.Row, nc)
      .Value = Now()
      .NumberFormat = "mm.dd.yyyy hh:mm:ss"
    End With
    If Me.Cells(4, nc + 1).Value = "Time (hh:mm:ss)" Then
      With Me.Cells(na.Row, nc + 1)
        .FormulaR1C1 = "=RC[-1]-RC[-2]"
        .NumberFormat = "hh:mm:ss"
        .Value = .Value
      End With
    End If
    If Me.Cells(4, nc + 1).Value = "Time (hh:mm:ss)" Then
      With Me.Cells(na.Row, nc + 1)
        .FormulaR1C1 = "=RC[-1]-RC[-2]"
        .NumberFormat = "hh:mm:ss"
        .Value = .Value
      End With
    End If
  End If
  With Me.Cells(2, 1)
    .ClearContents
    .Select
  End With
  .EnableEvents = True
  .ScreenUpdating = True
End With
End Sub

@Hiker,
It might change the VBA code so that, if it is over 24 hours, to write in cell with this header Time (hh:mm:ss)something like: 2 d hh: mm: ss or 5 d hh: mm: ss
(2 d hh: mm: ss - 2 days hh: mm: ss)

Thank you.

 

[ShinoHei]

Hi Hiker, just wondering if I would be able to add an additional column between the existing A and B columns to include a name field which will be populated using vlookup search of the barcode in another sheet. thanks in advanced!

 

[hiker95]

Hi Hiker, just wondering if I would be able to add an additional column between the existing A and B columns to include a name field which will be populated using vlookup search of the barcode in another sheet. thanks in advanced!

ShinoHei,

Welcome to the MrExcel forum.

To start off, and, in order to continue, I would like to see your actual raw data workbook/worksheets.

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com

 

[ShinoHei]

https://www.dropbox.com/s/1rav1g9ysu2iuzm/TimeLog.renamed?dl=0

thanks for your time for helping out!

 

[bigb52]

I am trying to make a log for our rental guns to be logged in and out throughout the day and i tried using the code that was posted on here and it worked ok but i cant seem to get it to allow for a slot for multiple names to be entered for one barcode.

this is kinda what i want to achieve. any help is appreciated.

rental log #	Renter's Name	time out	time in	renters name	time out	time in	renters name	time out	time in
3121	robert	2/9/2018 15:34	2/9/2018 15:34
3151	charlie	2/27/2018 17:23	2/27/2018 17:23

<colgroup><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[hiker95]

ShinoHei,

When I attempted to open/download your workbook I received the following messasge:

.renamed files can’t be previewed.
TimeLog.renamed · 31.34 KB


Please try again.

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com

 

[ShinoHei]

ShinoHei,

When I attempted to open/download your workbook I received the following messasge:

.renamed files can’t be previewed.
TimeLog.renamed · 31.34 KB


Please try again.

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com

I have renamed the file to .renamed from .xlsm. the below link is to the actual xlsm file.

Thanks!

https://www.dropbox.com/s/1rav1g9ysu2iuzm/TimeLog.xlsm?dl=0

 

[hiker95]

I have renamed the file to .renamed from .xlsm. the below link is to the actual xlsm file.

ShinoHei,

I have had problems in the past when attempting to download an Excel file with macros, with the xlsm file extension.

Please rename a copy of the workbook using the xlsx file extension, and, remove all macros, and, then repost on dropbox.


And, in your next reply please also display your original macro code.

Then post your original VBA code, below, please use Code Tags - like this:

[code=rich]

Paste your code here.

[/code]

 

[ShinoHei]

Here's a xlsx version:

https://www.dropbox.com/s/0makvo6um5sqcxo/TimeLog.xlsx?dl=0

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' hiker95, 12/18/2012
' http://www.mrexcel.com/forum/excel-questions/672492-scan-barcode-excel-date-time-stamp-out.html
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) = Now
    ElseIf lc > 2 Then
      Cells(Target.Row, lc + 1) = Now
    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) = Now
      ElseIf lc > 2 Then
        Cells(fr, lc + 1) = Now
      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
ThisWorkbook.Save
End Sub