Barcode scanning with Excel

[Chief1904]

My office is trying to go paperless with our hunting program and issue ID cards with bar codes. I'm trying to have a barcode scanner be able to scan the ID card and pull up their information in excel or access. How can I do this? My boss doesn't want to spend $12,000 on a full setup of software and hardware. Any help would be great!

 

[L. Howard]

Hi Alex,

Give this a try.

Copy code and paste the code below into the worksheet VB Editor of Sheet2. (Right click the tab > View Code > paste in large white space.)
Then scan or type in the barcode values in either of A2, A6 or A10.

The barcode MUST have the S, M or L as the 11th character in the barcode. (Including spaces)

Howard


Here is a working example workbook.

https://www.dropbox.com/s/mgcdmctv7c6fa1n/Yellow Green Blue Scan Drop Box.xlsm?dl=0


Here is the code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count > 1 Then Exit Sub
 
    Dim MyCells As Range
    Dim aLen As String
    
    Set MyCells = Range("A2,A6,A10")
    aLen = Mid(Target, 11, 1)

    
Application.EnableEvents = False
    
If Not Application.Intersect(MyCells, Range(Target.Address)) Is Nothing Then
    

  If Target.Address = "$A$2" Then
    Cells(2, 1).Copy Range("C" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(2, 1).Copy Range("I" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(2, 1).Copy Range("J" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(2, 1).Copy Range("K" & Rows.Count).End(xlUp)(2)
    
  End If

  If Target.Address = "$A$6" Then
    Cells(6, 1).Copy Range("E" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(6, 1).Copy Range("L" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(6, 1).Copy Range("M" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(6, 1).Copy Range("N" & Rows.Count).End(xlUp)(2)
    
  End If

  If Target.Address = "$A$10" Then
    Cells(10, 1).Copy Range("G" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(10, 1).Copy Range("O" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(10, 1).Copy Range("P" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(10, 1).Copy Range("Q" & Rows.Count).End(xlUp)(2)
  End If

End If


Application.EnableEvents = True
    
End Sub

 

[Sidjer]

Hey Howard,
it works GREAT! Thank You Much!
I'm still playing with the code you gave me, because I'm adding multiple sheets and tables with different groups.
Maybe one more thing to add (pretty sure more to come), but for now I would like to prevent double "scanning" same barcode in a group, so one value can not be repeated even if it's scanned twice... (because there will not be product with same barcode value)
I've decided that I'll use one sheet for each group, and without much VB knowledge I "trimmed" the code for my case, and it seems to work. (sheet2)
If you may help with repeated values as well, will be much appreciated! Thank you one more time!

Alex

https://www.dropbox.com/s/apvv5st7rayf6xh/mrexcel2.xlsm?dl=0

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count > 1 Then Exit Sub
 
    Dim aLen As String
    
    aLen = Mid(Target, 11, 1)
    
Application.EnableEvents = False
   
  If Target.Address = "$E$2" Then
    
    If aLen = "S" Then Cells(2, 5).Copy Range("A" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(2, 5).Copy Range("B" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(2, 5).Copy Range("C" & Rows.Count).End(xlUp)(2)
    
  End If


Application.EnableEvents = True
    
End Sub


Sub xxx()
Application.EnableEvents = True
End Sub

 

[L. Howard]

Hi Alex,

Try this. https://www.dropbox.com/s/pikmh6miw3awcxj/Yellow Green Blue Scan v1 Drop Box.xlsm?dl=0

Catches duplicate entry attempts. The message alerts you to a duplicate entry and where it is within the columns I to Q. The entry cell, A2, A6 or A10 is cleared and re-selected for another scan. The b-code entry that was the duplicate is logged in column "X" and the date in column "Y".

If the b-code entry is NOT a duplicate, you get a message alert as such and the b-code is properly posted. You will likely want to delete this alert as it will be bothersome on your real working sheet. Easy enough to do.

The headers for columns I to Q are NOT merged cells. You should use Center Across Selection on Home tab under Format > Alignment. Best to stay away from merged cells whenever you can with columns of data, tables, etc. as advised by many pro's and MVP's here in the forum.

Howard

Here is the code:

Option Explicit

Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count > 1 Then Exit Sub
 
   Dim MyCells As Range
   Dim aLen As String
   
    Set MyCells = Range("A2,A6,A10")
    aLen = Mid(Target, 11, 1)
    
Application.EnableEvents = False


Dim varRows() As Variant
Dim i As Long, myFirst As Long, myLast As Long
Dim myRng As Range
Dim oRange As Range


myFirst = Columns("I").Column
myLast = Columns("Q").Column
ReDim Preserve varRows(myLast - myFirst)

'/ Finds the row number of the longest column between I and Q
For i = myFirst To myLast
    varRows(i - myFirst) = Cells(Rows.Count, i).End(xlUp).Row
Next


If Not Application.Intersect(MyCells, Range(Target.Address)) Is Nothing Then
 
Set oRange = Worksheets(1).Range("I1:Q" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)

If Not oRange Is Nothing Then
    MsgBox oRange & "  - is a duplicate entry, see cell " & oRange.Address
    Target.Copy Range("X" & Rows.Count).End(xlUp)(2)
    Range("X" & Rows.Count).End(xlUp).Offset(, 1) = Date
    Target.Select
    Target.ClearContents
    Application.EnableEvents = True
    Exit Sub
  Else
  
     '/ This is the message box code to delete when not wanted any more,  Leave the space "Else" to "End If" blank.
    MsgBox "Non duplicate entry, and will be posted in I to Q columns." & vbCr & vbCr & _
          "(You can delete this message any time you want." & vbCr & _
          "It is here to help you see what the code is doing.)"

End If


  If Target.Address = "$A$2" Then
    Cells(2, 1).Copy Range("C" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(2, 1).Copy Range("I" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(2, 1).Copy Range("J" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(2, 1).Copy Range("K" & Rows.Count).End(xlUp)(2)
    
  End If

  If Target.Address = "$A$6" Then
    Cells(6, 1).Copy Range("E" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(6, 1).Copy Range("L" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(6, 1).Copy Range("M" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(6, 1).Copy Range("N" & Rows.Count).End(xlUp)(2)
    
  End If

  If Target.Address = "$A$10" Then
    Cells(10, 1).Copy Range("G" & Rows.Count).End(xlUp)(2)
    If aLen = "S" Then Cells(10, 1).Copy Range("O" & Rows.Count).End(xlUp)(2)
    If aLen = "M" Then Cells(10, 1).Copy Range("P" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(10, 1).Copy Range("Q" & Rows.Count).End(xlUp)(2)
  End If

End If

Application.EnableEvents = True
    
End Sub

 

[Sidjer]

Hi Howard!

Thank you again for your help! I'm trying to adjust the code to my worksheet and I don't know what I'm doing wrong...
Sheet4 (TC)

https://www.dropbox.com/s/j0zx3ecoxunwn6g/inventory_.xlsm?dl=0

Option Explicit

Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count > 1 Then Exit Sub
 
   Dim MyCells As Range
   Dim aLen As String
   
    Set MyCells = Range("A3")
    aLen = Mid(Target, 11, 1)
    
Application.EnableEvents = False




Dim varRows() As Variant
Dim i As Long, myFirst As Long, myLast As Long
Dim myRng As Range
Dim oRange As Range




myFirst = Columns("A").Column
myLast = Columns("B").Column
ReDim Preserve varRows(myLast - myFirst)


'/ Finds the row number of the longest column between I and Q
For i = myFirst To myLast
    varRows(i - myFirst) = Cells(Rows.Count, i).End(xlUp).Row
Next




If Not Application.Intersect(MyCells, Range(Target.Address)) Is Nothing Then
 
Set oRange = Worksheets(4).Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)


If Not oRange Is Nothing Then
   MsgBox oRange & "  - is a duplicate entry, see cell " & oRange.Address
   Target.Copy Range("J" & Rows.Count).End(xlUp)(2)
   Range("J" & Rows.Count).End(xlUp).Offset(, 1) = Date
   Target.Select
   Target.ClearContents
   Application.EnableEvents = True
   Exit Sub
  Else
  
    '/ This is the message box code to delete when not wanted any more,  Leave "Else" to "End If" blank
   MsgBox "Non duplicate entry, and will be posted in I to Q columns." & vbCr & vbCr & _
          "(You can delete this message any time you want." & vbCr & _
          "It is here to help you see what the code is doing.)"
End If




  If Target.Address = "$E$3" Then
    
    If aLen = "M" Then Cells(3, 5).Copy Range("A" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(3, 5).Copy Range("B" & Rows.Count).End(xlUp)(2)
    
  End If


  
End If


Application.EnableEvents = True
    
End Sub


Sub xxx()
Application.EnableEvents = True
End Sub

 

[L. Howard]

Hi alex,

Try this. You have the scan-in cell miss labeled and a worksheet naming convention mistake.

See red font lines, then discard.

There are four ways for the Set oRange, the one in use in this code here,

Set oRange = Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)

is fine as long as you are in the sheet module, the other three would work in the sheet module or a standard module to identify the sheet to which you want to set oRange on.

It can be confusing when you have Sheet4 named as "TC" and it is the only sheet, so it is actually Worksheets(1) or Worksheets("TC")

Howard

The code.

Option Explicit

Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count > 1 Then Exit Sub
 
   Dim MyCells As Range
   Dim aLen As String

     '/[COLOR="#FF0000"]Set MyCells = Range("A3")[/COLOR]
    Set MyCells = Range("E3")
    aLen = Mid(Target, 11, 1)
    
Application.EnableEvents = False


Dim varRows() As Variant
Dim i As Long, myFirst As Long, myLast As Long
Dim myRng As Range
Dim oRange As Range


myFirst = Columns("A").Column
myLast = Columns("B").Column
ReDim Preserve varRows(myLast - myFirst)

'/ Finds the row number of the longest column between I and Q
For i = myFirst To myLast
    varRows(i - myFirst) = Cells(Rows.Count, i).End(xlUp).Row
Next


If Not Application.Intersect(MyCells, Range(Target.Address)) Is Nothing Then

'Set oRange = Worksheets("TC").Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)
'Set oRange = Sheets("TC").Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)
'Set oRange = Worksheets(1).Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)
Set oRange = Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)


'/[COLOR="#FF0000"]Set oRange = Worksheets(4).Range("A1:B" & Application.Max(varRows)).Find(Target, lookat:=xlWhole)[/COLOR]


If Not oRange Is Nothing Then
   MsgBox oRange & "  - is a duplicate entry, see cell " & oRange.Address
   Target.Copy Range("J" & Rows.Count).End(xlUp)(2)
   Range("J" & Rows.Count).End(xlUp).Offset(, 1) = Date
   Target.Select
   Target.ClearContents
   Application.EnableEvents = True
   Exit Sub
  Else
  
    '/ This is the message box code to delete when not wanted any more,  Leave "Else" to "End If" blank
   MsgBox "Non duplicate entry, and will be posted in A or B columns." & vbCr & vbCr & _
          "(You can delete this message any time you want." & vbCr & _
          "It is here to help you see what the code is doing.)"
End If


  If Target.Address = "$E$3" Then
    
    If aLen = "M" Then Cells(3, 5).Copy Range("A" & Rows.Count).End(xlUp)(2)
    If aLen = "L" Then Cells(3, 5).Copy Range("B" & Rows.Count).End(xlUp)(2)
    
  End If

  
End If

Application.EnableEvents = True
    
End Sub

 

[Sidjer]

Thank you, Howard!
It works great! I'll put it in practice to see how it handle the data!
An enormous THANKS and Respect for what you're doing!

p.s Is it OK to ask more questions here? )

 

[L. Howard]

Okay good. And you're welcome.

More questions are welcome, basically they should be pertinent to the matters at hand in this thread and to some degree about the unknowns that may pop up with a given solution to the original problem.

If a way completely different aspect of your project arises, then it would probably be appropriate to post to a new thread. You would get a larger number of people looking for a solution than just me and whatever lurkers this thread has.

Howard

 

[Sidjer]

Let's say I have "sheet1" and "sheet2"
in "sheet1" column "A" i have values entered by the scanner... what I want to do is
in "sheet2", "C1" enter the value(scan it) and function formula will lookup the value in "sheet1" "A:A" and will return it in "sheet2" "B:B" (if posible "cut"/"delete" it from "sheet1" "A:A" and paste it in "sheet2" "B:B")
I'm trying a index/match function, but nothing I try is working.

If you think this should be posted in a different thread please let me know!
Thank you!

Alex.

 

[L. Howard]

[QUOTE
If you think this should be posted in a different thread please let me know!
Thank you!
[/QUOTE]

Hi Alex,

It's okay here, sorta another step in your scan project I guess.

So you scan ABC123 into C1 (sheet2) then search column A (sheet1) for ABC123 and, if there, Cut from column A and paste in column B (sheet2).

Now scan ABC321 into C1, if found on sheet1, where does it go on sheet2?
Does it go in the first empty cell below ABC123? Or does it REPLACE ABC123?

A formula can only return a value to the cell it is in. It cannot find a second value and return it to the cell below. Nor can it Cut/Delete values it looks up.

So, it looks like we need a Worksheet_Change event macro to find the scanned value and return it to column B, either as a broadening list or as the replacement value to B1.

Howard

 

[L. Howard]

[/QUOTE]
So, it looks like we need a Worksheet_Change event macro to find the scanned value and return it to column B, either as a broadening list or as the replacement value to B1.

Howard[/QUOTE]

Hi Alex,

Since it was easy to write the code for either copy-to-sheet2 method, a list or always to B1, I included both options in the code.

The code, as below, will provide a list. To Cut to B1 only, comment out this line...

aScan.Cut Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp)(2)

And remove the... '/B1/ from these lines.

'/B1/ aScan.Cut Sheets("Sheet2").Range("B1")
'/B1/ Sheets("Sheet2").Range("B1").ClearContents

Copy the code into the Sheet2 module, and scan into C1 on sheet2.

Howard

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Count > 1 Then Exit Sub
If Target <> Range("$C$1") Then Exit Sub

Dim LRow As Long
Dim aScan As Range 'sheet1 A:A list
Dim cScan As String 'sheet2 C1 scan-In

Application.EnableEvents = False

cScan = Sheets("Sheet2").Range("C1")

If cScan = "" Then
    Exit Sub
  ElseIf IsNumeric(cScan) Then
    cScan = Val(cScan) '/ converts a "text" number to a value
  Else
    '/ is text and that is okay
End If

With Sheets("Sheet1")

    LRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    
    Set aScan = Sheets("Sheet1").Range("A2:A" & LRow).Find(What:=cScan, _
                     LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                     SearchDirection:=xlNext, MatchCase:=False)

    If Not aScan Is Nothing Then
        aScan.Cut Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp)(2)
        '/B1/  aScan.Cut Sheets("Sheet2").Range("B1")
       
      ElseIf aScan Is Nothing Then
              MsgBox " No match found."
        '/B1/ Sheets("Sheet2").Range("B1").ClearContents
    End If
[C1].Select
End With

Application.EnableEvents = True

End Sub