第7课练习题：连续排序号

jiahua1010

第7课练习题 - jiahua1010.rar (12.52 KB, 下载次数: 3)

2012-2-28 12:13 上传

点击文件名下载附件

mukeli

第一次坐沙发，希望不需要解压密码

从从容容

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

sunjing-zxl

E学委:sunjing-zxl

1. Sub 排序()
   
2.     Dim arr, arr1
   
3.     Dim i As Long, n As Long, m As Long
   
4.     arr = Range("A2:A" & [A65536].End(xlUp).Row)
   
5.     ReDim arr1(1 To UBound(arr), 1 To 1)
   
6.     n = arr(1, 1)
   
7.     m = 1
   
8.     arr1(1, 1) = m
   
9.     For i = 2 To UBound(arr)
   
10.         If arr(i, 1) = n + 1 Then
    
11.             n = arr(i, 1)
    
12.             m = m + 1
    
13.             arr1(i, 1) = m
    
14.         Else
    
15.             n = arr(i, 1)
    
16.             m = 1
    
17.             arr1(i, 1) = m
    
18.         End If
    
19.     Next i
    
20.     Range("B2:B" & [B65536].End(xlUp).Row + 1).ClearContents
    
21.     Range("B2").Resize(UBound(arr1), 1) = arr1
    
22. End Sub

复制代码

bikong01

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

雨后的风

第7课练习题（F03：雨后的风）.zip (13.92 KB, 下载次数: 7)

2012-2-28 13:22 上传

点击文件名下载附件

只做出来序号的排列，没做到效果图中给单元格设置颜色的排列……

无聊的疯子

1. 
   
2. Sub cc()
   
3. Dim X As Integer, Y As Integer
   
4.   Range("B:B").ClearContents
   
5.   For X = 2 To 16
   
6.     Y = Y + 1
   
7.     Cells(X, 2) = Y
   
8.     Y = IIf(Cells(X, 1) + 1 <> Cells(X + 1, 1), 0, Y)
   
9.   Next
   
10. End Sub
    

复制代码

无聊的疯子

1. 
   
2. Sub cc()
   
3. Dim X As Integer, Y As Integer
   
4.   Range("B:B").ClearContents
   
5.   For X = 2 To 16
   
6.     Y = Y + 1
   
7.     Cells(X, 2) = Y
   
8.     Y = IIf(Cells(X, 1) + 1 <> Cells(X + 1, 1), 0, Y)
   
9.   Next
   
10. End Sub
    

复制代码

hactnet

来交第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