Hi Claus,

Found a glitch that returns a subscript out of range.

This data errors:

P-3122
F3UT2BA000457 <note serial number here
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402

This data works fine:

P-3122
P-65439 <No serial number, P number instead
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402

If the FIRST P number entry has a serial number then it errors.
If the data starts with two non serial numbered P numbers it works fine.

I tried starting the error producing data in A2 and it worked but produces an error 400 AFTER the data is correctly handled on the sheet.

These are the codes I am using which have a few minor additions to what you wrote.

Thanks.
Howard


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
ClearLocateReturn

End Sub


Sub ClearLocateReturn()
Dim MyArr As Variant

MyArr = Range("C1", Range("E1").End(xlDown)).Value

Range("A:E").ClearContents

Range("A1").Resize(UBound(MyArr, 1), UBound(MyArr, 2)) = MyArr
End Sub


And in a standard module:

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