Hi Howard,

Am Sun, 29 Mar 2015 03:36:27 -0700 (PDT) schrieb L. Howard:

This code works, but it's a seven minute ride.

I tried several ways. The fastest one was this way:

Sub ReDoData()
Dim varCheck As Variant, varTmp As Variant
Dim myDic As Object
Dim i As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myDic = CreateObject("Scripting.Dictionary")

With Sheets("Orginal List")
.Range("C1:EJ950").UnMerge
.Range("XFD1").FormulaArray = _

"=IFERROR(ADDRESS(MIN(IF($C$1:$EJ$950=A1,ROW($1:$9 50))),MIN(IF($C$1:$EJ$950=A1,COLUMN(C:EJ)))),"""") "
.Range("XFD1").AutoFill Destination:=.Range("XFD1:XFD1858")
.Range("XFD1:XFD1858").Calculate

varTmp = .Range("XFD1:XFD1858")
.Columns("XFD").ClearContents

For i = 1 To UBound(varTmp)
myDic(varTmp(i, 1)) = varTmp(i, 1)
Next

varCheck = myDic.items

For i = 1 To UBound(varCheck)
If varCheck(i) < "" Then
.Range(varCheck(i)).Cut .Range(varCheck(i)).Offset(1, -1)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional