Hi Derick,

Am Fri, 23 Oct 2015 08:20:48 +0200 schrieb Claus Busch:

try:

Sub Rearrange()

sorry, forgot the case if all numbers greater 10

Try:

Sub Rearrange()
Dim myCnt As Long, i As Long, n As Long
Dim varData() As Variant

myCnt = Application.CountIf(Range("B4:G4"), "<11")
If myCnt = 0 Then Exit Sub

Application.ScreenUpdating = False

If myCnt = 6 Then
For i = 5 To 5 - 2 + myCnt
Range(Cells(i, 2), Cells(i, 6)).Value _
= Range(Cells(i - 1, 3), Cells(i - 1, 7)).Value
Cells(i, 7) = Cells(i - 1, 2)
Next
Else
For i = 2 To 7
ReDim Preserve varData(myCnt - 1)
If Cells(4, i) < 11 Then
varData(n) = Cells(4, i)
n = n + 1
End If
Next
Range("B5").Resize(, UBound(varData) + 1) = varData
For i = 6 To 6 - 1 + UBound(varData)
Range(Cells(i, 2), Cells(i, 2 + UBound(varData))).Value _
= Range(Cells(i - 1, 3), Cells(i - 1, 2 +
UBound(varData))).Value
Cells(i, 2 + UBound(varData)) = Cells(i - 1, 2)
Next
End If
Application.ScreenUpdating = True
End Sub


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