区域排序取数值的问题，谢谢！

jinball

zhaogang1960 发表于 2014-1-3 15:42
其他你自己修改一下试试吧
请看附件

太棒了，搞定，终于明白了，{:soso_e128:}太感谢了，另外那个取数的时候带着颜色行不行？能不能实现？

zhaogang1960

jinball 发表于 2014-1-3 16:00
太棒了，搞定，终于明白了，太感谢了，另外那个取数的时候带着颜色行不行？能不能实现？

ADO没有这个功能

jinball

zhaogang1960 发表于 2014-1-3 16:01
ADO没有这个功能

那让字体变粗的功能有没有？总之就是想它不一样，突出显示一下

zhaogang1960

jinball 发表于 2014-1-3 16:09
那让字体变粗的功能有没有？总之就是想它不一样，突出显示一下

如果底色不是由条件格式生成的，可以用Find查找

jinball

zhaogang1960 发表于 2014-1-3 16:14
如果底色不是由条件格式生成的，可以用Find查找

您是说如果不是由条件格式产生的颜色就可以一起取过去吗？如果可以的如何实现？

zhaogang1960

jinball 发表于 2014-1-3 16:20
您是说如果不是由条件格式产生的颜色就可以一起取过去吗？如果可以的如何实现？

请先把条件格式删除，并手工涂色，条件格式我不会操作

jinball

zhaogang1960 发表于 2014-1-3 16:34
请先把条件格式删除，并手工涂色，条件格式我不会操作

好了，删除条件格式了 意甲-威廉.rar (35.85 KB, 下载次数: 4)

2014-1-3 16:41 上传

点击文件名下载附件

zhaogang1960

jinball 发表于 2014-1-3 16:42
好了，删除条件格式了

使用Excel工作表排序法：

1. Sub Sheet2()
   
2.     Dim arr, brr(1 To 1000, 0 To 10), i&, j&, m&, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = Sheets("Sheet2")
   
5.     sh.Cells.Clear
   
6.     With Sheets("Sheet1")
   
7.         For i = 1 To Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row Step 10
   
8.             m = m + 1
   
9.             .Cells(i, 1).Resize(10, 13).Sort Key1:=.Cells(i, 9), Order1:=1, Header:=xlNo
   
10.             arr = .Cells(i, 12).Resize(10)
    
11.             brr(m, 0) = "I" & i & ":L" & i + 9
    
12.             For j = 1 To 10
    
13.                 brr(m, j) = arr(j, 1)
    
14.                 .Cells(i + j - 1, 12).Copy
    
15.                 sh.Cells(m, j + 1).PasteSpecial Paste:=xlPasteFormats
    
16.             Next
    
17.         Next
    
18.     End With
    
19.     sh.[a1].Resize(m, 11) = brr
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

zhaogang1960

1. Sub Sheet3()
   
2.     Dim arr, brr(1 To 1000, 0 To 10), i&, j&, m&, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = Sheets("Sheet3")
   
5.     sh.Cells.Clear
   
6.     With Sheets("Sheet1")
   
7.         For i = 1 To Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row Step 10
   
8.             m = m + 1
   
9.             .Cells(i, 1).Resize(10, 13).Sort Key1:=.Cells(i, 10), Order1:=1, Header:=xlNo
   
10.             arr = .Cells(i, 12).Resize(10)
    
11.             brr(m, 0) = "J" & i & ":L" & i + 9
    
12.             For j = 1 To 10
    
13.                 brr(m, j) = arr(j, 1)
    
14.                 .Cells(i + j - 1, 12).Copy
    
15.                 sh.Cells(m, j + 1).PasteSpecial Paste:=xlPasteFormats
    
16.             Next
    
17.         Next
    
18.     End With
    
19.     sh.[a1].Resize(m, 11) = brr
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

zhaogang1960

1. Sub Sheet4()
   
2.     Dim arr, brr(1 To 1000, 0 To 10), i&, j&, m&, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = Sheets("Sheet4")
   
5.     sh.Cells.Clear
   
6.     With Sheets("Sheet1")
   
7.         For i = 1 To Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row Step 10
   
8.             m = m + 1
   
9.             .Cells(i, 1).Resize(10, 13).Sort Key1:=.Cells(i, 11), Order1:=1, Header:=xlNo
   
10.             arr = .Cells(i, 12).Resize(10)
    
11.             brr(m, 0) = "K" & i & ":L" & i + 9
    
12.             For j = 1 To 10
    
13.                 brr(m, j) = arr(j, 1)
    
14.                 .Cells(i + j - 1, 12).Copy
    
15.                 sh.Cells(m, j + 1).PasteSpecial Paste:=xlPasteFormats
    
16.             Next
    
17.         Next
    
18.     End With
    
19.     sh.[a1].Resize(m, 11) = brr
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码