第一次坐沙发，希望不需要解压密码
D03 从从容容
Sub 排序()
Dim x, i As Integer
x = 1
Range("b2") = 1
For i = 2 To Range("a65536").End(xlUp).Row - 1
If Cells(i + 1, 1).Value = Cells(i, 1).Value + 1 Then
x = x + 1
Cells(i + 1, 2) = x
Else
x = 1
Cells(i + 1, 2) = 1
End If
Next i
End Sub
Sub test()
Dim i As Long, k As Long
k = 1
For i = 2 To Range("a65536").End(xlUp).Row
If Cells(i + 1, 1) - 1 = Cells(i, 1) Then
Cells(i, 2) = k
k = k + 1
Else
Cells(i, 2) = k
k = 1
End If
Next
End Sub
E学委:sunjing-zxlSub 排序()
Dim arr, arr1
Dim i As Long, n As Long, m As Long
arr = Range("A2:A" & .End(xlUp).Row)
ReDim arr1(1 To UBound(arr), 1 To 1)
n = arr(1, 1)
m = 1
arr1(1, 1) = m
For i = 2 To UBound(arr)
If arr(i, 1) = n + 1 Then
n = arr(i, 1)
m = m + 1
arr1(i, 1) = m
Else
n = arr(i, 1)
m = 1
arr1(i, 1) = m
End If
Next i
Range("B2:B" & .End(xlUp).Row + 1).ClearContents
Range("B2").Resize(UBound(arr1), 1) = arr1
End Sub
Sub aa()
Dim x As Integer
Dim mrow As Integer
mrow = Range("a65336").End(xlUp).Row
For x = 2 To mrow
If Cells(x, 1) + 1 <> Cells(x + 1, 1) Then
Cells(x + 1, 2) = 1
Else:
Cells(2, 2) = 1
Cells(x + 1, 2) = Cells(x, 2) + 1
End If
Next x
Cells(mrow + 1, 2) = ""
End Sub
只做出来序号的排列，没做到效果图中给单元格设置颜色的排列……
Sub cc()
Dim X As Integer, Y As Integer
Range("B:B").ClearContents
For X = 2 To 16
Y = Y + 1
Cells(X, 2) = Y
Y = IIf(Cells(X, 1) + 1 <> Cells(X + 1, 1), 0, Y)
Next
End Sub
Sub cc()
Dim X As Integer, Y As Integer
Range("B:B").ClearContents
For X = 2 To 16
Y = Y + 1
Cells(X, 2) = Y
Y = IIf(Cells(X, 1) + 1 <> Cells(X + 1, 1), 0, Y)
Next
End Sub
本帖最后由 hactnet 于 2012-2-28 14:00 编辑
来交第7课练习，连续排序
H组，H15:hactnet
Sub rg()
Dim x As Integer
Range("b2") = 1
For x = 2 To 15 Step 1
If Range("a" & x + 1) - Range("a" & x) = 1 Then
Range("b" & (x + 1)) = Range("b" & x) + 1
Else
Range("b" & (x + 1)) = 1
End If
Next x
End Sub