Hi Howard,

Am Mon, 30 Mar 2015 08:50:29 -0700 (PDT) schrieb L. Howard:

Here is the transfer part I have, where the ElseIf part does not work.

try:

Sub ReDoData()
Dim varCheck As Variant, varTmp As Variant
Dim myDic As Object
Dim rngBig As Range, rngTmp As Range
Dim i As Long, n As Long
Dim st As Double

st = Timer

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

With Sheets("Orginal List")
.Activate
.Range("A1:HQ1858").Replace what:=Chr(10), replacement:="",
lookat:=xlPart
.Range("A1:HQ1858").Select
With Selection
.WrapText = False
.MergeCells = False
End With

.Range("XFD1").FormulaArray = _

"=IFERROR(ADDRESS(MIN(IF($C$1:$HQ$950=A1,ROW($1:$9 50))),MIN(IF($C$1:$HQ$950=A1,COLUMN(C:HQ)))),"""") "
.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 = 0 To UBound(varCheck)
If varCheck(i) < "" Then
If Len(.Range(varCheck(i)).Offset(1, 1)) = 0 Then
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 23).Value = .Range(varCheck(i)).Offset(,
1).Resize(, 23).Value
Else
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 12).Value = .Range(varCheck(i)).Resize(,
12).Value
End If
.Range(varCheck(i)).Cut .Range(varCheck(i)).Offset(1, -1)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Timer - st, "0.000")
End Sub

Or :

Sub ReDoData2()
Dim varCheck As Variant
Dim Tmp, c
Dim i As Long
Dim st As Double

st = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Orginal List")
.Activate
.Range("A1:HQ1858").Replace what:=Chr(10), replacement:="",
lookat:=xlPart
.Range("A1:HQ1858").Select
With Selection
.WrapText = False
.MergeCells = False
End With

varCheck = .Range("A1:A1858")

For i = 1 To UBound(varCheck)
Tmp = varCheck(i, 1)
c = Evaluate("=ADDRESS(MIN(IF($C$1:$HQ$950=" & Tmp _
& ",ROW($1:$950))),MIN(IF($C$1:$HQ$950=" & Tmp &
",COLUMN(C:HQ))))")
If Not IsError(c) Then
If Len(Range(c)) = 0 Then
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 23).Value = Range(c).Offset(, 1).Resize(,
23).Value
Else
Sheets("New List").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(, 12).Value = Range(c).Resize(, 12).Value
End If
.Range(c).Cut .Range(c).Offset(1, -1)
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - st, "0.000")
End Sub


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