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!

 

[Sidjer]

Hi Howard,

Sorry I was away for the weekend!
And I didn't mean you to make the whole thing, but appreciate your help!
If you put all categories in one sheet is fine, but I should mention it earlier that its better to divide all categories in 5 groups (5 sheets) like ones in dashboard (Rodeo Showroom, FBA, WEB, Exotic Web, Calfskin Web) .
if you put them all in one sheet, maybe it will be better to visually separate all scan-in cells by groups.
Thanks!

Alex.

 

[L. Howard]

Hi Alex,

I'll give some thought to the grouping of the sheet/categories.

I have a question on the sheets like Dark Brindle 6 x 8, 710E, HJQ, Cowboy Decoration etc. These sheets have a single column for the scan-in item, where the others have multiple columns with a header of S, M, L and a few other single letter headers. These letters provide the key to which column the incoming data is listed.

What would be an example of the scan-in data for these single column sheet mentioned above? Or does every scan-in go to the single column without regard to a S, M, L as the 11th character?

Howard

 

[Sidjer]

Hi Howard,

Not all groups have all 3 sizes (S,M,L)
the ones you mentioned have only one size 6x8=L; HJQ,710E,COWBOY DECORATION=L. in vb of each of these sheet is mentioned what 11th character should have, could be one, two, three or more. But you don't have to worry about it, I think I'll be able to change it later.
Thanks.

Alex.

 

[L. Howard]

Hi Alex,

Give this a try.

https://www.dropbox.com/s/l4hjzzsc3vpqf3u/FBA Inventory OP.xlsm?dl=0

There is an info comment in cell B8, tells what's happening on sheet FBAout.

You will see come color coding in cells B1:B5, which should relate to the worksheet you have selected in A2. This is not accurate at present, the code uses Interior.ColorIndex and the colors you have in cells A1 of the search sheets do not appear to be from the ColorIndex. Not important now, and you may not even want the color info.

Instead of a macro in each of the 50+ plus sheets, there is one macro to do all that.

So you have two major macros, one in ThisWorkbook Module and one in FBAout sheet Module.
There are some service macros in standard Module 1 and Module 2.

Give it some test shots and lets see if it is doing what you want it to do.

Howard


Here are the two major macros.


In Sheet FBAout

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2,A5")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    
Application.ScreenUpdating = False

On Error GoTo CleanUp

Dim aScan As Range 'look for this value in one of 50+ different sheets(A:F columns)
Dim cScan As Variant 'is sheet FBAout A5 scanned-in value
Dim MySheet As String, strCol As String
Dim myCol As Long
Dim dest As Range, myCell As Range
Dim aColor As Long

Select Case Target.Address(0, 0)
    Case "A2"
        MySheet = Target
        cScan = Target.Offset(3, 0)
        aColor = Sheets(MySheet).Cells(1, 1).Interior.ColorIndex
        Range(Cells(1, 2), Cells(5, 2)).Interior.ColorIndex = aColor
        'MsgBox aColor
        
    Case "A5"
        cScan = Target 'Range("A5")
        MySheet = Target.Offset(-3, 0) 'Target ' drop down with all sheet names in cell FBAout A2
        
End Select

If cScan = "" Then
    Exit Sub
End If


With Sheets(MySheet)

    Set myCell = .Range("A2:I2").Find("Enter Below", LookIn:=xlValues, lookat:=xlWhole)
    If Not myCell Is Nothing Then strCol = ConvertToLetter(myCell.Column - 3)
    
    Set aScan = .Range("A:" & strCol).Find(cScan, lookat:=xlWhole)
    
    If Not aScan Is Nothing Then

        myCol = Application.Match(MySheet, Sheets("FBAout").Range("1:1"), 0)
        ActiveWindow.ScrollColumn = myCol

        Set dest = Sheets("FBAout").Cells(Rows.Count, myCol).End(xlUp)(2)
        dest.Offset(0, 1) = Date
        aScan.Cut Destination:=dest
       
      Else
        MsgBox " No match found."
        
    End If

End With
CleanUp:

[A5].ClearContents
[A5].Activate
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

In ThisWorkbook

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name = "Dashboard" Or Sh.Name = "FBAout" Then Exit Sub

Dim myCell As Range, dest As Range, oRange As Range, sCol As Range
Dim myCol As String, sStr As String

Application.EnableEvents = False
On Error GoTo CleanUp

Set myCell = Range("A1:I2").Find("Enter Below", LookIn:=xlValues, lookat:=xlWhole).Offset(1, 0)
If Target.Address <> myCell.Address Then Exit Sub

myCol = ConvertToLetter(myCell.Column - 3)
If Len(Target) > 0 Then
    Set oRange = Range("A2:" & myCol & "1000").Find(Target, lookat:=xlWhole)
End If

If Not oRange Is Nothing Then
   MsgBox oRange & "  - is a duplicate entry, see cell " & oRange.Address
   Set dest = Cells(Rows.Count, "L").End(xlUp)(2)
   dest = Target
   dest.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
End If

Select Case Sh.Name
    Case "Dark Brindle 6 x 8", "710E", "HJQ_", "Cowboy Decoration"
        If Mid(Target, 11, 1) = "L" Then
            Set dest = Cells(Rows.Count, "A").End(xlUp)(2)
        End If
    Case "XX 121 Calfskin", "80%Brown & White Calfskin", "Brown & 80% White Calfskin", _
        "Chocolate Calfskin", "Black & White Calfskin", "Cream Caramel Calfskin", "Brown & White Calfskin Web", _
        "Black & White Calfskin Web", "Panda Calfskin Web", "Panda Calfskin", "Tropical White Calfskin", _
        "Creamy Caramel Calfskin Web", "Tropical White Calfskin Web"
        If Mid(Target, 11, 1) = "C" Then
            Set dest = Cells(Rows.Count, "A").End(xlUp)(2)
        End If
    Case "Round Star Brown Web", "Round Star Black&White Web"
        If Mid(Target, 11, 1) = "R" Then
            Set dest = Cells(Rows.Count, "A").End(xlUp)(2)
        End If
    Case Else
        Select Case Mid(Target, 11, 1)
            Case "S"
                sStr = "Small"
            Case "M"
                sStr = "Medium"
            Case "L"
                sStr = "Large"
            Case "E"
                sStr = "Exotic"
            Case "C"
                sStr = "Calfskin"
            Case "R"
                sStr = "Round Rug"
        End Select
        Set sCol = Range("A2:" & myCol & "2").Find(sStr, LookIn:=xlValues, lookat:=xlWhole)
        If Not sCol Is Nothing Then
            Set dest = Cells(Rows.Count, sCol.Column).End(xlUp)(2)
        End If
End Select

If Not dest Is Nothing Then
    dest = Target
    Target.Select
    Target.ClearContents
Else
    Target.Select
    MsgBox "Check your entry"
End If
CleanUp:
Application.EnableEvents = True
End Sub

 

[Sidjer]

Hi Howard,

You did a tremendous work and I appreciate that!
The workbook is very close to what I wanted, and it may need few tweaks to be 100%, but all these will be in vain if problem that button in "B6" fixes persists, it happens to me as well in all sheets, not just "FBAout", and I can not figure out when and why it appears.
Using this in practice may be a big problem , because if I scan-in in inventory or scan-out for FBAout and this problem occurs, I won't be able to notice because:
I might not have visual contact with monitor, even if I'm watching the monitor, the last scanned values will be somewhere down... and I don't receive any warnings that values I scanned didn't do any changes to the system!
I understand that at the moment you don't know how to fix that. Maybe I should consider to switch to Microsoft Access where EndUsers do not have direct access to database. avoiding accidentally changing or removing something. And I guess I'll be able to use VB codes you gave me for sorting products by 11th character.
Thank You!

Alex.

 

[L. Howard]

Hi Alex,

The EnableEvents issue is troublesome for sure. I'll relook what possibly may be causing that.

I has professional input to tweak the codes I had written, hence, a single macro to replace the 50 sheets codes. It was not a problem on the pro's computer. I was hoping it was just mine.

Howard

 

[L. Howard]

Hi Alex,

Maybe this one will work properly. Check it out and let me know.

https://www.dropbox.com/s/ur26m27jhi0nfc9/FBA Inventory_New1.1.xlsm?dl=0

Howard

 

[L. Howard]

Hi Alex,

I do believe I posted the wrong link.

Ignore the the link in #67

Give this a test.

https://www.dropbox.com/s/lkf7i5q0ma3cugb/FBA Inventory_New1.1 (2).xlsm?dl=0

Howard

 

[L. Howard]

Hi Alex,

Here is a version that depicts the color group of the current sheet selected on sheet FBAout, and also scrolls the column that matches the sheet name selection prior to actually making a scan-in. You can review the sheet columns by merely selecting the sheet name in A2 and see the column adjacent.

https://www.dropbox.com/s/n7da58k4euorj4i/FBA Inventory_New1.1 (2)_Color DBOX.xlsm?dl=0

Howard

Here is the code for the sheet FBAout sheet module.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("A2,A5")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    
  Dim aScan As Range 'look for this value in one of 50+ different sheets(A:F columns)
  Dim cScan As Variant ' Is sheet FBAout A5 scanned-in value
  Dim MySheet As String, strCol As String
  Dim dest As Range, myCell As Range
  Dim CIcolor As Long
  Dim myCol As Long
  Dim Rslt As Integer
  

  Const ShowDurationSecs As Integer = 2 ' fade time for pop up (sec's)
    
If Not Intersect(Target, Range("A2")) Is Nothing Then

    Range("B1:B5").Interior.ColorIndex = xlNone
    CIcolor = CIRng(Sheets("" & Target & "").Range("A1"))
    'MsgBox CIcolor
    Range("B1:B5").Interior.ColorIndex = CIcolor
    
    myCol = Application.Match(Target, Sheets("FBAout").Range("1:1"), 0)
        ActiveWindow.ScrollColumn = myCol
        [A5].Activate
    
    Rslt = CreateObject("WScript.Shell").PopUp( _
        "Scan Sheet " & """" & Target & """" & " now.", ShowDurationSecs, "Barcode Scan Cell")
   
End If


On Error GoTo CleanUp

Select Case Target.Address(0, 0)
    Case "A2"
        MySheet = Target
        cScan = Target.Offset(3, 0)

    Case "A5"
        cScan = Target 'Range("A5")
        MySheet = Target.Offset(-3, 0) 'Target = drop down with all sheet names in cell FBAout A2
End Select

If cScan = "" Then
    Exit Sub
End If


With Sheets(MySheet)
        

    Set myCell = .Range("A2:I2").Find("Enter Below", LookIn:=xlValues, lookat:=xlWhole)
    If Not myCell Is Nothing Then strCol = ConvertToLetter(myCell.Column - 3)
    
    Set aScan = .Range("A:" & strCol).Find(cScan, lookat:=xlWhole)

    If Not aScan Is Nothing Then

        myCol = Application.Match(MySheet, Sheets("FBAout").Range("1:1"), 0)
     '   ActiveWindow.ScrollColumn = myCol

        Set dest = Sheets("FBAout").Cells(Rows.Count, myCol).End(xlUp)(2)
        dest.Offset(0, 1) = Date
        aScan.Cut Destination:=dest
       
      Else
        MsgBox " No match found."
        
    End If

End With
CleanUp:

Columns(myCol).AutoFit
[A5].ClearContents
[A5].Activate

End Sub

 

[L. Howard]

Hi Alex,

Was wondering if the last version of the workbook is of any use to you.

Howard