Stock inventory cout with serial numbers sorting query

S

smeeagain1

New Member
Joined
Feb 20, 2014
Messages
9
Hi guys. I have a scanner that scans stock barcodes and serial numbers into a memory chip on the scanner.I then dock the scanner and download the info into excel.
I need to sort the data into 2 columns based on cell contents.

If I scan an item without a serial number, I just want it to stay in column A, however, if I scan a serialized item (ie: scan the barcode and then scan the serial number), I need Excel to take that serial and place it in column B next to the items barcode entry (ie: move the serial up one line and into column B).
Also I need to then remove the blank line from the sheet.
The items scanned have a Product number (denoted by a P-####) when scanned, so I could differentiate the serials and products using this delimiter. Can anyone assist please?
Thanks.


******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;">******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>
 
Sort by date Sort by votes
Try this, where you will call the sub named MyScanA.
(See notes at bottom of sub MyScanA.)


Put this in the sheet module that has the data.

Code: 
Option Explicit
Option Base 1

Sub MyScanA()
'by Claus

Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long

Dim myCt As Long

LRow = Cells(Rows.Count, 1).End(xlUp).row

myArr = Range("A2:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")

j = 1
For i = LBound(myArr) To UBound(myArr)

    ReDim Preserve arrOut(myCt, 2)
    If Left(myArr(i, 1), 1) = "P" Then

        arrOut(j, 1) = myArr(i, 1)

        j = j + 1

    Else
        arrOut(j - 1, 2) = myArr(i, 1)

    End If
Next

Range("A2:B" & LRow).ClearContents

Range("A2").Resize(UBound(arrOut), 2) = arrOut

'/ For final results to show on Sheet 1 col C and D of data sheet.
ReScan1

'/ If you want to see results of MyScanA before running ReScan1
'/ then comment out ReScan1 and call it by another means after viewing MyScanA  results.

End Sub


Put this in a Standard Module... (Insert > Module).

Code: 
Option Explicit
Option Base 1

Sub ReScanA() 'by Claus

Dim LRow As Long
Dim arrIn As Variant
Dim arrOut() As Variant
Dim myArr As Variant
Dim dic As Object
Dim i As Long

LRow = Cells(Rows.Count, 1).End(xlUp).row
arrIn = Range("A2:B" & LRow)
Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arrIn, 1)
    dic.Item(arrIn(i, 1)) = arrIn(i, 1)
Next

myArr = dic.items
For i = 0 To UBound(myArr)
    ReDim Preserve arrOut(dic.Count, 2)
    arrOut(i + 1, 1) = myArr(i)
    With WorksheetFunction
        If .VLookup(myArr(i), Range("A2:B" & LRow), 2, 0) = 0 Then
            arrOut(i + 1, 2) = .CountIf(Range("A2:A" & LRow), myArr(i))
        Else
            arrOut(i + 1, 2) = .VLookup(myArr(i), Range("A2:B" & LRow), 2, 0)
        End If
    End With
Next
Range("C2").Resize(dic.Count, 2) = arrOut
End Sub



Howard
 
Upvote 0
Howard. This works well except if you have a count of a particular P-**** number and one happens to have a serial number. It appears the code dumps the serial number in this case.
Is there any way to move these serialised items to the new columns prior to the count?
Workflow:
1) Move all non-P-**** to column B (as is already done).
2)Move all lines with serials then next to them to columns C & D.
3) Count remainder in column A and consolidate count, putting results into Columns C & D.

Results would look like this:
Note: Total count for P-8901 is 5. (One has a serial number)

​
P-9876ABCDE
1​
P-5678FGRTTTRGF
1​
P-7675HFHFHFH
1​
P-8901ABCDE
1​
P-8901

​
4​
P-3456

​
1​
P-6543

​
2​
P-54463

​
1​

<tbody>
</tbody>



Note1​
 
Last edited:
Upvote 0
Put this in the sheet module.

Code: 
Option Explicit
Option Base 1

Sub MyScanA()
'/ by Claus

Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long

Dim myCt As Long

LRow = Cells(Rows.Count, 1).End(xlUp).row

myArr = Range("A2:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")

j = 1
For i = LBound(myArr) To UBound(myArr)

    ReDim Preserve arrOut(myCt, 2)
    If Left(myArr(i, 1), 1) = "P" Then

        arrOut(j, 1) = myArr(i, 1)

        j = j + 1

    Else
        arrOut(j - 1, 2) = myArr(i, 1)

    End If
Next

Range("A2:B" & LRow).ClearContents

Range("A2").Resize(UBound(arrOut), 2) = arrOut

'
ReScan1
End Sub


And put this in a standard module.

Code: 
Option Explicit

Sub ReScan1()
'/ by Claus
Dim LRow1 As Long, LRow2 As Long
Dim myArr As Variant

With Sheets("Sheet1")
    LRow1 = .Cells(.Rows.Count, 1).End(xlUp).row
    myArr = .Range("A1:B" & LRow1)
End With

With Sheets("Sheet2")
    .Range("A2").Resize(LRow1, 2) = myArr
    .Range("A2:B" & LRow1 + 1).RemoveDuplicates _
        Columns:=Array(1, 2), Header:=xlNo

    LRow2 = .Cells(.Rows.Count, 1).End(xlUp).row
    
    .Range("C2:C" & LRow2).Formula = "=SumProduct(--(Sheet1!" _
      & "$A$1:$A$" & LRow1 & "=A2),--(Sheet1!$B$1:$B$" & LRow1 & "=B2))"

End With
End Sub

Run Sub MyScanA() which will call Sub ReScan1().

You will need a sheet 2, column A, B and C clear for the returned data.
Best if on sheet 1 there are no Headers and on sheet 2 it doesn't matter, put headers if you want.

Howard
 
Upvote 0
Or perhaps it is better for you to have the data processed and shown on sheet 1.

If so then copy this into the sheet module.

Code: 
Option Explicit
Option Base 1

Sub MyScanA1()
'/ by Claus

Dim LRow As Long
Dim MyArr As Variant
Dim MyArr1 As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long
Dim myCt As Long

Range("B:E").ClearContents

LRow = Cells(Rows.Count, 1).End(xlUp).Row

MyArr = Range("A2:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")

j = 1
For i = LBound(MyArr) To UBound(MyArr)

    ReDim Preserve arrOut(myCt, 2)
    If Left(MyArr(i, 1), 1) = "P" Then

        arrOut(j, 1) = MyArr(i, 1)

        j = j + 1

    Else
        arrOut(j - 1, 2) = MyArr(i, 1)

    End If
Next

Range("A2:B" & LRow).ClearContents

Range("A2").Resize(UBound(arrOut), 2) = arrOut

'
ReScan

  MyArr1 = Range("C1", Range("E1").End(xlDown)).Value
  Range("A:E").ClearContents
  Range("A1").Resize(UBound(MyArr1, 1), UBound(MyArr1, 2)) = MyArr1

End Sub


And this into a standard module.


Code: 
Option Explicit

Sub ReScan()
Dim LRow1 As Long, LRow2 As Long
Dim arrIn As Variant
Dim arrOut() As Variant
Dim MyArr As Variant
Dim dic As Object
Dim i As Long

'/Modify the sheet name
With Sheets("Sheet1")
    LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    arrIn = .Range("A1:B" & LRow1)
    Set dic = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(arrIn, 1)
        dic.Item(arrIn(i, 1)) = arrIn(i, 1)
    Next

    MyArr = dic.items
    For i = 0 To UBound(MyArr)
        ReDim Preserve arrOut(dic.Count - 1, 1)
        arrOut(i, 0) = MyArr(i)
        arrOut(i, 1) = WorksheetFunction.VLookup(arrOut(i, 0), _
            .Range("A1:B" & LRow1), 2, 0)
    Next
    .Range("C1").Resize(dic.Count, 2) = arrOut
    LRow2 = .Cells(.Rows.Count, 3).End(xlUp).Row
    With .Range("E1:E" & LRow2)
        .Formula = "=SumProduct(--($A$1:$A$" & LRow1 & _
            "=C1),--($B$1:$B$" & LRow1 & "= D1))"
        .Value = .Value
    End With
End With
End Sub

And then run Sub MyScanA1()

Howard
 
Upvote 0
Hi Howard,

This works great on a small amount of data, however, i am getting errors when I dump a real amount of stock scans into tge XLSM sheet.
I get a "Subscript out of range" error.
Almost there.... :)


The data I am using is below:

[TABLE="width: 73"]
<colgroup><col></colgroup><tbody>[TR]
[TD]P-1645[/TD]
[/TR]
[TR]
[TD="align: right"]1753502010[/TD]
[/TR]
[TR]
[TD]P-1645[/TD]
[/TR]
[TR]
[TD="align: right"]1753502022[/TD]
[/TR]
[TR]
[TD]P-4311[/TD]
[/TR]
[TR]
[TD="align: right"]1750502068[/TD]
[/TR]
[TR]
[TD]P-4311[/TD]
[/TR]
[TR]
[TD="align: right"]1750502068[/TD]
[/TR]
[TR]
[TD]P-3122[/TD]
[/TR]
[TR]
[TD]F3UT2BA000457[/TD]
[/TR]
[TR]
[TD]P-3122[/TD]
[/TR]
[TR]
[TD]F3UT3C5000495[/TD]
[/TR]
[TR]
[TD]P-3122[/TD]
[/TR]
[TR]
[TD]F3UT3C4000059[/TD]
[/TR]
[TR]
[TD]P-3123[/TD]
[/TR]
[TR]
[TD]QBDA1C7000402[/TD]
[/TR]
[TR]
[TD]P-3123[/TD]
[/TR]
[TR]
[TD]QBDA1C2000052[/TD]
[/TR]
[TR]
[TD]P-4860[/TD]
[/TR]
[TR]
[TD]P-4860[/TD]
[/TR]
[TR]
[TD]P-4860[/TD]
[/TR]
[TR]
[TD]P-4860[/TD]
[/TR]
[TR]
[TD]P-4416[/TD]
[/TR]
[TR]
[TD="align: right"]1711502041[/TD]
[/TR]
[TR]
[TD]P-4318[/TD]
[/TR]
[TR]
[TD="align: right"]1711502045[/TD]
[/TR]
[TR]
[TD]P-4318[/TD]
[/TR]
[TR]
[TD="align: right"]1711502045[/TD]
[/TR]
[TR]
[TD]P-4318[/TD]
[/TR]
[TR]
[TD="align: right"]1711502065[/TD]
[/TR]
[TR]
[TD]P-4688[/TD]
[/TR]
[TR]
[TD]2BA0613000098[/TD]
[/TR]
[TR]
[TD]P-3001[/TD]
[/TR]
[TR]
[TD="align: right"]1712502052[/TD]
[/TR]
[TR]
[TD]P-3001[/TD]
[/TR]
[TR]
[TD="align: right"]1712502052[/TD]
[/TR]
[TR]
[TD]P-3001[/TD]
[/TR]
[TR]
[TD="align: right"]1712502052[/TD]
[/TR]
[TR]
[TD]P-3142[/TD]
[/TR]
[TR]
[TD]P166196000058[/TD]
[/TR]
[TR]
[TD]P-3142[/TD]
[/TR]
[TR]
[TD]P166195000080[/TD]
[/TR]
[TR]
[TD]P-1450[/TD]
[/TR]
[TR]
[TD]F3HG4B8000648[/TD]
[/TR]
[TR]
[TD]P-1450[/TD]
[/TR]
[TR]
[TD]F3HG4A7004304[/TD]
[/TR]
[TR]
[TD]P-1450[/TD]
[/TR]
[TR]
[TD]F3HG4B8000511[/TD]
[/TR]
[TR]
[TD]P-1389[/TD]
[/TR]
[TR]
[TD]P-1118[/TD]
[/TR]
[TR]
[TD="align: right"]152502087[/TD]
[/TR]
[TR]
[TD]P-1118[/TD]
[/TR]
[TR]
[TD="align: right"]152502087[/TD]
[/TR]
[TR]
[TD]P-1118[/TD]
[/TR]
[TR]
[TD="align: right"]152502087[/TD]
[/TR]
[TR]
[TD]P-1118[/TD]
[/TR]
[TR]
[TD="align: right"]152502087[/TD]
[/TR]
[TR]
[TD]P-1118[/TD]
[/TR]
[TR]
[TD="align: right"]152502087[/TD]
[/TR]
[TR]
[TD]P-4614[/TD]
[/TR]
[TR]
[TD="align: right"]101502002[/TD]
[/TR]
[TR]
[TD]P-1115[/TD]
[/TR]
[TR]
[TD="align: right"]152502052[/TD]
[/TR]
[TR]
[TD]P-1115[/TD]
[/TR]
[TR]
[TD="align: right"]152502052[/TD]
[/TR]
[TR]
[TD]P-1115[/TD]
[/TR]
[TR]
[TD="align: right"]152502052[/TD]
[/TR]
[TR]
[TD]P-1115[/TD]
[/TR]
[TR]
[TD="align: right"]152502052[/TD]
[/TR]
[TR]
[TD]P-1115[/TD]
[/TR]
[TR]
[TD="align: right"]152502052[/TD]
[/TR]
[TR]
[TD]P-3124[/TD]
[/TR]
[TR]
[TD]PW0B1B5000172[/TD]
[/TR]
[TR]
[TD]P-3124[/TD]
[/TR]
[TR]
[TD]PW0B1B8000636[/TD]
[/TR]
[TR]
[TD]P-2772[/TD]
[/TR]
[TR]
[TD]P-2772[/TD]
[/TR]
[TR]
[TD]P-2772[/TD]
[/TR]
[TR]
[TD]P-2772[/TD]
[/TR]
[TR]
[TD]P-3950[/TD]
[/TR]
[TR]
[TD="align: right"]1750502077[/TD]
[/TR]
[TR]
[TD]P-3950[/TD]
[/TR]
[TR]
[TD="align: right"]1750502077[/TD]
[/TR]
[TR]
[TD]P-4664[/TD]
[/TR]
[TR]
[TD="align: right"]154500003[/TD]
[/TR]
[TR]
[TD]P-4664[/TD]
[/TR]
[TR]
[TD="align: right"]154500003[/TD]
[/TR]
[TR]
[TD]P-1438[/TD]
[/TR]
[TR]
[TD="align: right"]151502008[/TD]
[/TR]
[TR]
[TD]P-2560[/TD]
[/TR]
[TR]
[TD="align: right"]162500048[/TD]
[/TR]
[TR]
[TD]P-2560[/TD]
[/TR]
[TR]
[TD="align: right"]1760500006[/TD]
[/TR]
[TR]
[TD]P-2732[/TD]
[/TR]
[TR]
[TD="align: right"]1760500006[/TD]
[/TR]
[TR]
[TD]P-1444[/TD]
[/TR]
[TR]
[TD="align: right"]1780502001[/TD]
[/TR]
[TR]
[TD]P-3126[/TD]
[/TR]
[TR]
[TD]PVO21B6001989



[/TD]
[/TR]
</tbody>[/TABLE]
******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>
 
Upvote 0
First make sure you have no blanks in column A and check that there are no merged cells in the data that you put in column A.

I found a couple cells that were merged, but after unmerging there was still the error.

Seemed if the first P-number entry had a serial number it would error. If it did not have a serial number then it seemed to work okay.

Put these codes in a standard module.

Run Sub MyScan().

Howard

Code: 
Option Explicit

Sub MyScan()
'/by Claus
Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long
Dim myCt As Long

With Sheets("Sheet1")
    LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    myArr = .Range("A1:A" & LRow)
    myCt = WorksheetFunction.CountIf(.Range("A1:A" & LRow), "P" & "*")

    For i = LBound(myArr) To UBound(myArr)
        ReDim Preserve arrOut(myCt - 1, 1)
        If Left(myArr(i, 1), 1) = "P" Then
            arrOut(j, 0) = myArr(i, 1)
            j = j + 1
        Else
            arrOut(j - 1, 1) = myArr(i, 1)
        End If
    Next

    .Range("A1:B" & LRow).ClearContents
    .Range("A1").Resize(UBound(arrOut) + 1, 2) = arrOut
End With
ReScan
End Sub


Sub ReScan()
'/ by Claus
Dim LRow1 As Long, LRow2 As Long
Dim myArr As Variant

'/Modify the sheet name
With Sheets("Sheet1")
    LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    myArr = .Range("A1:B" & LRow1)

    .Range("C1").Resize(LRow1, 2) = myArr
    .Range("C1:D" & LRow1 + 1).RemoveDuplicates _
        Columns:=Array(1, 2), Header:=xlNo
    LRow2 = .Cells(.Rows.Count, 3).End(xlUp).Row
    With .Range("E1:E" & LRow2)
        .Formula = "=SumProduct(--($A$1:$A$" & LRow1 & _
            "=C1),--($B$1:$B$" & LRow1 & "= D1))"
        .Value = .Value
    End With
End With
End Sub
 
Upvote 0
Howard,
I tried the above code and it works well except for any line items that have a serial number that starts with the letter "P".
It seems to treat the Serial as a P-*** number instead of handling it as a a serial number.
Can we change the variable for the P-**** from "P" to "P-" as no serial would start with this.
See results from Columns C, D & E after running Macro.

RAW DATA:
P-3001
139E1403289
P-3001
139E1403292
P-3001
135B1300968
P-3142
P166196000058
P-3142
P166195000080
P-3143
F3HG4B8000648

<tbody>
</tbody>


RESULT:
P-3001
139E1403289
1​
P-3001
139E1403292
1​
P-3001
135B1300968
1​
P-3142

​
2​
1​
1​
P-3143
F3HG4B8000648
1​
P-3143
F3HG4B8000511
1​

<tbody> [TD="colspan: 2"] P166196000058
[/TD]
[TD="colspan: 2"] P166195000080
[/TD]
</tbody>


Thanks again.******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>
 
Upvote 0
Try this. Note the RED text.

Find these two lines and change from this:

Rich (BB code): 
 myCt = WorksheetFunction.CountIf(.Range("A1:A" & LRow), "P" & "*")

If Left(myArr(i, 1), 1) = "P" Then

To this

Rich (BB code): 
 myCt = WorksheetFunction.CountIf(.Range("A1:A" & LRow), "P-" & "*")

If Left(myArr(i, 1), 1) = "P-" Then

Seemed to work in my small test.

Howard
 
Upvote 0
Seems to fail with "Subscript out of range" execution error after I change the "P" to "P-" in both areas.
Hit the debug and gets to this line: arrOut(j - 1, 1) = myArr(i, 1)


******** type="cosymantecnisbfw" cotype="cs" id="SILOBFWOBJECTID" style="width: 0px; height: 0px; display: block;"></object>
 
Upvote 0
Try this change.

Rich (BB code): 
 If Left(myArr(i, 1), 1) = "P-" Then

To

Rich (BB code): 
 If Left(myArr(i, 1), 2) = "P-" Then

Howard
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Barcode scanning tool
Replies
0
Views
1K
D3FCON
D
C
  • Question Question
Scan and conditional print
Replies
0
Views
484
Cristigal
C
C
  • Question Question
Stock inventory - count unique sequences from barcode
Replies
0
Views
607
ChemistryBMS
C
G
  • Question Question
Using Excel formula to create HTML code text referencing specific cells
Replies
0
Views
1K
gvsumich
G
D
  • Question Question
Creating an automated inventory system using excell and a barcode scanner
Replies
0
Views
6K
Devorr
D

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top