[已解决]求一个EXcl 循环筛选的语句

long595930

跪求啊，附件里有说明

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-25 15:23

long595930 发表于 2013-1-25 14:20
哥们能留个QQ 或者电话吗

代码有问题直接在这说，这个不便留。

跳转到最佳答案楼层

long595930

人在线呢，有什么看不明白可以问哦，或者加我QQ 420124367

hwc2ycy

新建 Microsoft Excel 工作表.rar (334.11 KB, 下载次数: 7)

2013-1-25 13:55 上传

点击文件名下载附件

hwc2ycy

建议把每次更新号的列标专门存储在一个特定的单元格，这样文档关闭后不用从J列开始了，虽然只用多点几次而已。

hwc2ycy

另外，如果数据的列如果会不停的增加的话，代码就还得改下。

long595930

偶学习下，不过先谢谢啦

long595930

这位大哥，您是不是忘记贴代码了= =

hwc2ycy

修改后数据列可增加，另外如果数据操作的列超出了限制会提示"数据列溢出而退出操作。
新建 Microsoft Excel 工作表.rar (336.02 KB, 下载次数: 7)

2013-1-25 14:05 上传

点击文件名下载附件

hwc2ycy

再修改，在代码开始运行后就进行列标溢出的判断，避免先操作了一大段数据后，发现无效再提示，这样可以提高效率。

1. Option Explicit
   
2. 
   
3. Public Col&
   
4. 
   
5. Sub test()
   
6.     Dim iRow&, arrj, i&, LastCol&
   
7.     Application.ScreenUpdating = False
   
8.     iRow = Cells(Rows.Count, "j").End(xlUp).Row '行
   
9.     LastCol = [a1].End(xlToRight).Column        '列
   
10.     If Col >= LastCol Then MsgBox "数据列标溢出": Exit Sub   '列溢出判断
    
11.    
    
12.     arrj = Range("j2:j" & iRow).Value                       '读取J列数据
    
13.     Range("j2:j" & iRow) = arrj                             '写回数值
    
14.    
    
15.     With ActiveSheet.Sort
    
16.         With .SortFields
    
17.             .Clear                                          '先清空原有排序字段，再添加
    
18.             .Add Key:=Range( _
    
19.                       "J2:J" & iRow), SortOn:=xlSortOnValues, Order:=xlDescending    ', DataOption:= xlSortNormal
    
20.         End With
    
21.         .SetRange Range(Cells(1, 1), Cells(iRow, LastCol))      '设置排序区域
    
22.         .Header = xlYes                                         '标题行
    
23.         .Apply
    
24.     End With
    
25. 
    
26.     If Col = 0 Then                                             '工作簿打开后第一次执行时COL为0，所以改为J列
    
27.         Col = 11
    
28.     Else
    
29.         Col = Col + 1                                           '第二次或第N次运行，列自动加1
    
30.     End If
    
31. 
    
32.     arrj = Range(Cells(2, Col - 1), Cells(iRow, Col - 1))       '上列数据加
    
33.     For i = LBound(arrj) To UBound(arrj)
    
34.         arrj(i, 1) = arrj(i, 1) + 1                             '加1
    
35.     Next
    
36.     Range(Cells(2, Col), Cells(iRow, Col)) = arrj               '数据写回工作表
    
37.     MsgBox "操作完成", vbInformation + vbOKOnly
    
38.     Application.ScreenUpdating = True
    
39. End Sub

复制代码

long595930

哥们能留个QQ 或者电话吗