Hi Howard,

Am Wed, 1 Apr 2015 10:04:31 -0700 (PDT) schrieb L. Howard:

To be clear, if the code was to be run on another sheet with a different "map" of the solar panels, I would need to adjust the column ranges to match where the "two row" blocks occur. Correct?

try the following code. It looks for the merged cells and the columns
and you have not to hardcode the range:

Sub ReDoData()
Dim varCheck As Variant, varTmp As Variant, varCol As Variant
Dim varAdd() As Variant
Dim myDic As Object
Dim i As Long, n As Long, m As Long
Dim rngBig As Range, c As Range, myRng As Range, rngC As Range
Dim st As Double

st = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Orginal List")
.Activate
For Each rngC In .Range("C6:HQ950")
If rngC.MergeCells Then
ReDim Preserve varAdd(n)
varTmp = Split(rngC.MergeArea.Cells(1, 1).Address(1, 0),
"$")
varAdd(n) = varTmp(0)
n = n + 1
End If
Next
Set myDic = CreateObject("Scripting.Dictionary")
For n = 0 To UBound(varAdd)
myDic(varAdd(n)) = varAdd(n)
Next
varCol = myDic.items

For n = 0 To UBound(varCol)
If rngBig Is Nothing Then
Set rngBig = Columns(varCol(n))
Else
Set rngBig = Application.Union(rngBig, Columns(varCol(n)))
End If
Next


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

varCheck = .Range("A1:A1858")

For i = 1 To UBound(varCheck)
Set c = rngBig.Find(varCheck(i, 1), LookIn:=xlValues,
lookat:=xlWhole)
If Not c Is Nothing Then
m = m + 1
c.Cut c.Offset(1, -1)
If Len(c.Offset(, 12)) 0 Then
Sheets("New List").Range("A" & m).Resize(, 23).Value _
= c.Resize(, 23).Value
Else
Sheets("New List").Range("A" & m).Resize(, 12).Value _
= c.Resize(, 12).Value
m = m + 1
Sheets("New List").Range("B" & m).Resize(, 11).Value _
= c.Offset(1, 1).Resize(, 11).Value
End If
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox Format(Timer - st, "0.000")
End Sub


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