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

zhaogang1960

jinball 发表于 2014-1-7 16:16
已经重新说明了，在Sheet2-Sheet8中有说明，谢谢版主！

改为一个通用程序，各个工作表调用它：

1. Sub Main(s$)
   
2.     Dim a, arr, brr(1 To 1000, 0 To 10), i&, j&, m&, sh As Worksheet, lc%, f As Boolean
   
3.     Application.ScreenUpdating = False
   
4.     lc = Sheets("Sheet1").Range("a1").CurrentRegion.Columns.Count
   
5.     a = Split(s, ":")
   
6.     If UCase(a(0)) = "P" Then
   
7.         char = a(1)
   
8.     Else
   
9.         char = a(0)
   
10.         f = True
    
11.     End If
    
12.     列号 = GetColumn(char)
    
13.     Set sh = ActiveSheet
    
14.     sh.Cells.Clear
    
15.     Sheets("Sheet1").Copy
    
16.     With ActiveSheet
    
17.         For i = 1 To Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row Step 10
    
18.             m = m + 1
    
19.             .Cells(i, 1).Resize(10, lc).Sort Key1:=.Cells(i, 列号), Order1:=1, Header:=xlNo
    
20.             arr = .Cells(i, 16).Resize(10)
    
21.             If f Then
    
22.                 brr(m, 0) = UCase(a(0)) & i & ":P" & i + 9
    
23.             Else
    
24.                 brr(m, 0) = "P" & i & ":" & UCase(a(1)) & i + 9
    
25.             End If
    
26.             For j = 1 To 10
    
27.                 brr(m, j) = arr(j, 1)
    
28.                 .Cells(i + j - 1, 16).Copy
    
29.                 sh.Cells(m, j + 1).PasteSpecial Paste:=xlPasteFormats
    
30.             Next
    
31.         Next
    
32.     End With
    
33.     ActiveWorkbook.Close False
    
34.     sh.[a1].Resize(m, 11) = brr
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    
38. Function GetColumn(char)
    
39.     Dim t
    
40.     On Error Resume Next
    
41.     t = Columns(char & ":" & char).Column
    
42.     If Err.Number <> 0 Then GetColumn = "超出范围" Else GetColumn = t
    
43. End Function
    

复制代码

zhaogang1960

jinball 发表于 2014-1-7 16:16
已经重新说明了，在Sheet2-Sheet8中有说明，谢谢版主！

写一个各表都可以调用的程序：

1. Sub Main(s$)
   
2.     Dim a, arr, brr(1 To 1000, 0 To 10), i&, j&, m&, sh As Worksheet, lc%, f As Boolean
   
3.     Application.ScreenUpdating = False
   
4.     lc = Sheets("Sheet1").Range("a1").CurrentRegion.Columns.Count
   
5.     a = Split(s, ":")
   
6.     If UCase(a(0)) = "P" Then
   
7.         char = a(1)
   
8.     Else
   
9.         char = a(0)
   
10.         f = True
    
11.     End If
    
12.     列号 = GetColumn(char)
    
13.     Set sh = ActiveSheet
    
14.     sh.Cells.Clear
    
15.     Sheets("Sheet1").Copy
    
16.     With ActiveSheet
    
17.         For i = 1 To Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row Step 10
    
18.             m = m + 1
    
19.             .Cells(i, 1).Resize(10, lc).Sort Key1:=.Cells(i, 列号), Order1:=1, Header:=xlNo
    
20.             arr = .Cells(i, 16).Resize(10)
    
21.             If f Then
    
22.                 brr(m, 0) = UCase(a(0)) & i & ":P" & i + 9
    
23.             Else
    
24.                 brr(m, 0) = "P" & i & ":" & UCase(a(1)) & i + 9
    
25.             End If
    
26.             For j = 1 To 10
    
27.                 brr(m, j) = arr(j, 1)
    
28.                 .Cells(i + j - 1, 16).Copy
    
29.                 sh.Cells(m, j + 1).PasteSpecial Paste:=xlPasteFormats
    
30.             Next
    
31.         Next
    
32.     End With
    
33.     ActiveWorkbook.Close False
    
34.     sh.[a1].Resize(m, 11) = brr
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    
38. Function GetColumn(char)
    
39.     Dim t
    
40.     On Error Resume Next
    
41.     t = Columns(char & ":" & char).Column
    
42.     If Err.Number <> 0 Then GetColumn = "超出范围" Else GetColumn = t
    
43. End Function
    

复制代码

zhaogang1960

各表调用程序：

1. Private Sub CommandButton1_Click()
   
2.     Call Main("i:p")
   
3. End Sub

复制代码

1. Private Sub CommandButton1_Click()
   
2. Call Main("p:o")
   
3. End Sub

复制代码

zhaogang1960

请测试附件
意甲-威廉.rar (76.68 KB, 下载次数: 4)

2014-1-7 16:44 上传

点击文件名下载附件

jinball

zhaogang1960 发表于 2014-1-7 16:45
请测试附件

谢谢版主了，我先研究测试一下，非常感谢！

jinball

zhaogang1960 发表于 2014-1-7 16:45
请测试附件

版主老师在吗？这个表格出现问题了，Sheet6中的数据不能更新了，点击也没有用，请老师帮我检查一下，谢谢！
另外请老师注意一下，我在Sheet1当中添加了一些东西，不知道是不是我添加的东西造成的，以前没添加过东西的那个表格很好用，谢谢！请帮忙检查一下，非常感谢！ 法甲随机-20-365.zip (92.15 KB, 下载次数: 2)

2014-3-15 20:26 上传

点击文件名下载附件

LMY123

arr(m, j) = rs.Fields(0).Value