I need to compare a list of part numbers in Col. B from Sheet 1. When a
duplicate if sound, I need to copy the Part Number and corresponding Dates
(from Col. A) to Sheet 2 to read across in a row, such that the part number
shows up once, with all dates reading across the same row in subsequent
columns.
After comparing the first part number in the list, I have to compare the
next to the list, and the next and the next...

Example:

Sheet1: Col. A Col. B.
Date Part #
1/1/07 01234.0
1/3/07 04587.0
1/12/07 03874.0
1/24/07 01234.0
2/15/07 01234.0
2/18/07 04587.0
3/13/07 01234.0

Sheet 2: Col. A Col. B Col. C Col. D Col. E....
Part # 1st Date 2nd Date 3rd Date 4th Date
01234.0 1/1/07 1/24/07 2/15/07 3/13/07
04587.0 1/3/07 2/18/07

And so on down the list.
I'm having a problem getting the Dates into the "Next Empty Cell" on the
correct line. I'm also having a problem when I come to a part number that I
have already seen previously in the list.
Help, please.

Sub Macro1()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s2.Range("A:A").NumberFormat = "@"


s1.Activate
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

ior = 0
ioc = 1
Set r = s2.Range("A2")
n = Cells(Rows.Count, 1).End(xlUp).Row
r.Value = Range("B2").Value
p_old = r.Value
r.Offset(0, 1).Value = Range("A2").Value

For i = 3 To n
d = Cells(i, "A").Value
pn = Cells(i, "B").Value
If pn = p_old Then
ioc = ioc + 1
r.Offset(ior, ioc).Value = d
Else
ioc = 1
ior = ior + 1
r.Offset(ior, 0).Value = pn
r.Offset(ior, ioc).Value = d
p_old = pn
End If
Next
End Sub

the routine first sorts the source data.
--
Gary''s Student - gsnu200747


"Mim" wrote:

I need to compare a list of part numbers in Col. B from Sheet 1. When a
duplicate if sound, I need to copy the Part Number and corresponding Dates
(from Col. A) to Sheet 2 to read across in a row, such that the part number
shows up once, with all dates reading across the same row in subsequent
columns.
After comparing the first part number in the list, I have to compare the
next to the list, and the next and the next...

Example:

Sheet1: Col. A Col. B.
Date Part #
1/1/07 01234.0
1/3/07 04587.0
1/12/07 03874.0
1/24/07 01234.0
2/15/07 01234.0
2/18/07 04587.0
3/13/07 01234.0

Sheet 2: Col. A Col. B Col. C Col. D Col. E....
Part # 1st Date 2nd Date 3rd Date 4th Date
01234.0 1/1/07 1/24/07 2/15/07 3/13/07
04587.0 1/3/07 2/18/07

And so on down the list.
I'm having a problem getting the Dates into the "Next Empty Cell" on the
correct line. I'm also having a problem when I come to a part number that I
have already seen previously in the list.
Help, please.

On 27 sep, 19:33, Mim wrote:
I need to compare a list of part numbers in Col. B from Sheet 1. When a
duplicate if sound, I need to copy the Part Number and corresponding Dates
(from Col. A) to Sheet 2 to read across in a row, such that the part number
shows up once, with all dates reading across the same row in subsequent
columns.
After comparing the first part number in the list, I have to compare the
next to the list, and the next and the next...

Example:

Sheet1: Col. A Col. B.
Date Part #
1/1/07 01234.0
1/3/07 04587.0
1/12/07 03874.0
1/24/07 01234.0
2/15/07 01234.0
2/18/07 04587.0
3/13/07 01234.0

Sheet 2: Col. A Col. B Col. C Col. D Col. E....
Part # 1st Date 2nd Date 3rd Date 4th Date
01234.0 1/1/07 1/24/07 2/15/07 3/13/07
04587.0 1/3/07 2/18/07

And so on down the list.
I'm having a problem getting the Dates into the "Next Empty Cell" on the
correct line. I'm also having a problem when I come to a part number that I
have already seen previously in the list.
Help, please.

Hi Mim,

I Have cooked this:

Option Explicit

Public Sub AllDatesForEachPart()
Dim colPartnumbers As New Collection
Dim strSinglePartNumber As String
Dim lngSheet2Row As Long
Dim lngLoopPartnumbers As Long
Dim blnKnownPartnumber As Boolean
Dim datSingleDate As Date
Dim lngSheet2Column As Long

' collect all present partnumber from sheet 2
Sheets("Sheet2").Activate
Range("a2").Select
Do While Not IsEmpty(ActiveCell)
colPartnumbers.Add ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
' add new series of dates
Sheets("Sheet1").Activate
Range("B2").Select
Do While Not IsEmpty(ActiveCell)
strSinglePartNumber = ActiveCell.Value
datSingleDate = ActiveCell.Offset(0, -1).Value
If colPartnumbers.Count = 0 Then
blnKnownPartnumber = False
lngSheet2Row = 2
Else
blnKnownPartnumber = False
For lngLoopPartnumbers = 1 To colPartnumbers.Count
If colPartnumbers.Item(lngLoopPartnumbers) =
strSinglePartNumber Then
blnKnownPartnumber = True
lngSheet2Row = lngLoopPartnumbers + 1
Exit For
End If
Next
End If
If Not blnKnownPartnumber Then
colPartnumbers.Add strSinglePartNumber
lngSheet2Row = colPartnumbers.Count + 1
Worksheets("Sheet2").Cells(lngSheet2Row, 1).Value = "'" &
strSinglePartNumber
End If
lngSheet2Column = 2
Do While Not IsEmpty(Worksheets("sheet2").Cells(lngSheet2Row,
lngSheet2Column))
lngSheet2Column = lngSheet2Column + 1
Loop
Worksheets("sheet2").Cells(lngSheet2Row,
lngSheet2Column).Value = datSingleDate
ActiveCell.Offset(1, 0).Select


Loop

End Sub

It even collect allready transfered partnumbers from sheet2.

HTH,

Wouter.

Thank you. This works for the most part. There are two things, however, that
I need to work out:
1. I don't want all the part numbers to be copied over to Sheet 2. I need
only the ones that are duplicated.
2. I have other info in Columns C thru I on Sheet 1. For each of these
columns, the date is being double populated on Sheet 2. I need to change the
code so that it does not take other columns from Sheet 1 into account.
Thanks for all your help.

"RadarEye" wrote:

On 27 sep, 19:33, Mim wrote:
I need to compare a list of part numbers in Col. B from Sheet 1. When a
duplicate if sound, I need to copy the Part Number and corresponding Dates
(from Col. A) to Sheet 2 to read across in a row, such that the part number
shows up once, with all dates reading across the same row in subsequent
columns.
After comparing the first part number in the list, I have to compare the
next to the list, and the next and the next...

Example:

Sheet1: Col. A Col. B.
Date Part #
1/1/07 01234.0
1/3/07 04587.0
1/12/07 03874.0
1/24/07 01234.0
2/15/07 01234.0
2/18/07 04587.0
3/13/07 01234.0

Sheet 2: Col. A Col. B Col. C Col. D Col. E....
Part # 1st Date 2nd Date 3rd Date 4th Date
01234.0 1/1/07 1/24/07 2/15/07 3/13/07
04587.0 1/3/07 2/18/07

And so on down the list.
I'm having a problem getting the Dates into the "Next Empty Cell" on the
correct line. I'm also having a problem when I come to a part number that I
have already seen previously in the list.
Help, please.

Hi Mim,

I Have cooked this:

Option Explicit

Public Sub AllDatesForEachPart()
Dim colPartnumbers As New Collection
Dim strSinglePartNumber As String
Dim lngSheet2Row As Long
Dim lngLoopPartnumbers As Long
Dim blnKnownPartnumber As Boolean
Dim datSingleDate As Date
Dim lngSheet2Column As Long

' collect all present partnumber from sheet 2
Sheets("Sheet2").Activate
Range("a2").Select
Do While Not IsEmpty(ActiveCell)
colPartnumbers.Add ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
' add new series of dates
Sheets("Sheet1").Activate
Range("B2").Select
Do While Not IsEmpty(ActiveCell)
strSinglePartNumber = ActiveCell.Value
datSingleDate = ActiveCell.Offset(0, -1).Value
If colPartnumbers.Count = 0 Then
blnKnownPartnumber = False
lngSheet2Row = 2
Else
blnKnownPartnumber = False
For lngLoopPartnumbers = 1 To colPartnumbers.Count
If colPartnumbers.Item(lngLoopPartnumbers) =
strSinglePartNumber Then
blnKnownPartnumber = True
lngSheet2Row = lngLoopPartnumbers + 1
Exit For
End If
Next
End If
If Not blnKnownPartnumber Then
colPartnumbers.Add strSinglePartNumber
lngSheet2Row = colPartnumbers.Count + 1
Worksheets("Sheet2").Cells(lngSheet2Row, 1).Value = "'" &
strSinglePartNumber
End If
lngSheet2Column = 2
Do While Not IsEmpty(Worksheets("sheet2").Cells(lngSheet2Row,
lngSheet2Column))
lngSheet2Column = lngSheet2Column + 1
Loop
Worksheets("sheet2").Cells(lngSheet2Row,
lngSheet2Column).Value = datSingleDate
ActiveCell.Offset(1, 0).Select


Loop

End Sub

It even collect allready transfered partnumbers from sheet2.

HTH,

Wouter.