I have not done this in a long time and cannot remember how...
Want to look in sheet 3, row D... bottom up
find each Program entry (there can be 10+ entries for the same program)
Then copy those entries (program names) and past into sheet 2 starting with cell A5.
Just cannot remember how to do it

Hans,

I wrote a short macro to copy your data range to a blank column in your workbook and then use RemoveDuplicates to speed up the process. This new range of unique values is then cycled through in reverse to populate your destination list. Finally, the temporary column we added is cleared.

Hope this helps,

Ben

Sub ListPrograms()
Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim rPaste As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow

Set rCopy = Sheet3.Range("D1:D" & Sheet1.Range("D64000").End(xlUp).Row)
Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook
Set rPaste = Sheet2.Range("A5")

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size and copy the data
Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)
rCopy.Copy rCopy2

'Now, remove duplicates (assumes no headers)
rCopy2.RemoveDuplicates 1, xlNo

'Once again resize rCopy2 to cover reduced data range
'**(Check next line to ensure that the sheet name and column are correct)
Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp).Row)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
For x = rCopy2.Rows.Count To 1 Step -1
rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)
y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, clear the rCopy2 range as it is no longer necessary.
rCopy2.Clear
Application.ScreenUpdating = True

End Sub

On Wednesday, October 10, 2012 5:53:23 PM UTC-4, Ben McClave wrote:
Hans,



I wrote a short macro to copy your data range to a blank column in your workbook and then use RemoveDuplicates to speed up the process. This new range of unique values is then cycled through in reverse to populate your destination list. Finally, the temporary column we added is cleared.



Hope this helps,



Ben



Sub ListPrograms()

Dim rCopy As Range 'Range of values to check

Dim rCopy2 As Range 'Blank cell at the top of an unused column

Dim x As Long 'Used for cycling through the rCopy2 range

Dim y As Long 'Used for cycling through the rPaste range

Dim rPaste As Range 'First cell to receive the data



'First, set up the copy from range and the copy/paste to range

'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow



Set rCopy = Sheet3.Range("D1:D" & Sheet1.Range("D64000").End(xlUp).Row)

Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook

Set rPaste = Sheet2.Range("A5")



y = 0 'Set to zero to start



'Next, resize the rCopy2 range to match the rCopy range size and copy the data

Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)

rCopy.Copy rCopy2



'Now, remove duplicates (assumes no headers)

rCopy2.RemoveDuplicates 1, xlNo



'Once again resize rCopy2 to cover reduced data range

'**(Check next line to ensure that the sheet name and column are correct)

Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp)..Row)



'Now, cycle through each value in rCopy2 starting from the bottom _

and paste it to the final destination.

For x = rCopy2.Rows.Count To 1 Step -1

rPaste.Offset(y, 0).Value = rCopy2.Cells(x, 1)

y = y + 1 'Increment y to ensure next value goes into the cell below

Next x



'Finally, clear the rCopy2 range as it is no longer necessary.

rCopy2.Clear

Application.ScreenUpdating = True



End Sub

Ben, Cool...one little tweek and it worked DEAD ON!Had to change "Sheet3.Range("D1:D...." to D2 as I have headers.Thanks for the help. I have not done any of this in 8-9 years and just cannot remember any of it. So I may be reaching out again for some assistance.

Hans,

I'm glad to hear that it worked for you. Thanks for the feedback.

Ben

On Thursday, October 11, 2012 1:12:23 PM UTC-4, Ben McClave wrote:
Hans,



I'm glad to hear that it worked for you. Thanks for the feedback.



Ben

Now have an additional one for you....
You provided this code:
Set rPaste = Sheet2.Range("A5")

I have found I need the same information in an additional location, specifically Sheet2 starting in cell A36.
Tried three different ways
Set rPaste2 = Sheet2.Range("A36")
Set rPaste = Sheet2.Range("A5")&("A36")
Set rPaste = Sheet2.Range("A5", "A36")
Neither works... how would I do this?

Hans,

I've modified this a bit to do this for you. Please note I haven't tested it. Let me know if you have any issues with it.

Ben

Sub ListPrograms()
Dim rCopy As Range 'Range of values to check
Dim rCopy2 As Range 'Blank cell at the top of an unused column
Dim x As Long 'Used for cycling through the rCopy2 range
Dim y As Long 'Used for cycling through the rPaste range
Dim rPaste(1 to 2) As Range 'First cell to receive the data

'First, set up the copy from range and the copy/paste to range
'Application.ScreenUpdating = False 'Uncomment this line if macro runs slow

Set rCopy = Sheet3.Range("D2:D" & Sheet1.Range("D64000").End(xlUp).Row)
Set rCopy2 = Sheet1.Range("E1") 'Empty column somewhere in your workbook
Set rPaste(1) = Sheet2.Range("A5")
Set rPaste(2) = Sheet2.Range("A36")

y = 0 'Set to zero to start

'Next, resize the rCopy2 range to match the rCopy range size and copy the data
Set rCopy2 = rCopy2.Resize(rCopy.Rows.Count, 1)
rCopy.Copy rCopy2

'Now, remove duplicates (assumes no headers)
rCopy2.RemoveDuplicates 1, xlNo

'Once again resize rCopy2 to cover reduced data range
'**(Check next line to ensure that the sheet name and column are correct)
Set rCopy2 = Sheet1.Range("E1:E" & Sheet1.Range("E64000").End(xlUp).Row)

'Now, cycle through each value in rCopy2 starting from the bottom _
and paste it to the final destination.
For x = rCopy2.Rows.Count To 1 Step -1
rPaste(1).Offset(y, 0).Value = rCopy2.Cells(x, 1)
rPaste(2).Offset(y, 0).Value = rCopy2.Cells(x, 1)
y = y + 1 'Increment y to ensure next value goes into the cell below
Next x

'Finally, clear the rCopy2 range as it is no longer necessary.
rCopy2.Clear
Application.ScreenUpdating = True

End Sub

Hi Hans,

Am Wed, 10 Oct 2012 07:37:42 -0700 (PDT) schrieb Hans Hamm:

Want to look in sheet 3, row D... bottom up
find each Program entry (there can be 10+ entries for the same program)
Then copy those entries (program names) and past into sheet 2 starting with cell A5.

try:
Sheets("Sheet3").Columns("D:D").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A5"), Unique:=True


Regards
Claus Busch
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2