qpywsqp,
When you begin to scan in delegates for the first time, the active cell should be cell A2.
If the active cell, for some reason, is not cell A2, then the macro will move the delegate to cell A2...
And, then if you move the active cell below the last recorded delegate (by 1 or more rows) the macro will remove the blank rows in column A.
The macro will make the active cell, the next available blank cell in column A.
Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).
1. Copy the below code, by highlighting the code and pressing the keys
CTRL +
C
2. Select the worksheet in which your code is to run
3. Right click on the sheet tab and choose
View Code, to open the Visual Basic Editor
4. Where the cursor is flashing, paste the code by pressing the keys
CTRL +
V
5. Press the keys
ALT +
Q to exit the Editor, and return to Excel
Code:
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) = 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
Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension
.xlsm
Please test the new
Worksheet_Change event in the office before going into the field.
