[已解决]请帮助解决列排序移动问题

yizhih

请帮助解决列排序移动问题，谢谢！
列移动1.rar (20.52 KB, 下载次数: 28)

2012-3-12 17:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

bb75308973

2012-3-12 20:16

测试看看
列移动答案.zip (32.17 KB, 下载次数: 26)

2012-3-13 01:05 上传

点击文件名下载附件

1. Private Sub CommandButton1_Click()
   
2. Dim n As Integer, a As Integer, k As Integer
   
3. Dim rga As Range, rgb As Range, rgc As Range, rg As Range
   
4. Dim maxa As Integer, maxb As Integer, maxc As Integer
   
5. 
   
6. Application.ScreenUpdating = False
   
7. Range("BC5:BK107").ClearContents '清除原来的内容
   
8. Range("BM5:BU107").ClearContents
   
9. Range("BW5:CE107").ClearContents
   
10. a = [r2]
    
11. Set rga = Range("H107:Q107"): Set rgb = Range("U107:AD107"): Set rgc = Range("AG107:AQ107") '定义要取最大值的区域3个
    
12. On Error Resume Next
    
13. 'A区
    
14. k = 55
    
15. For n = 1 To a '取多少列就循环多少次
    
16. '如果第几大的值与前面一个不同就直接查找他的位置,如果相同等从上一个之后查找,这样就不会重复了
    
17. If Application.WorksheetFunction.Large(rga, n) <> Application.WorksheetFunction.Large(rga, n - 1) Then
    
18.     Set rg = rga.Find(Application.WorksheetFunction.Large(rga, n), , , xlWhole)
    
19. Else
    
20.     Set rg = rga.FindNext(rg)
    
21. End If
    
22. maxa = rg.Column
    
23. Range(Cells(5, maxa), Cells(107, maxa)).Copy '复制相应的列到相应的区域
    
24. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
25. k = k + 1
    
26. Next
    
27. Set rg = Nothing
    
28. 'B区
    
29. k = 65
    
30. For n = 1 To a
    
31. If Application.WorksheetFunction.Large(rgb, n) <> Application.WorksheetFunction.Large(rgb, n - 1) Then
    
32.     Set rg = rgb.Find(Application.WorksheetFunction.Large(rgb, n), , , xlWhole)
    
33. Else
    
34.     Set rg = rgb.FindNext(rg)
    
35. End If
    
36. maxb = rg.Column
    
37. Range(Cells(5, maxb), Cells(107, maxb)).Copy
    
38. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
39. k = k + 1
    
40. Next
    
41. Set rg = Nothing
    
42. 'C区
    
43. k = 75
    
44. For n = 1 To a
    
45. If Application.WorksheetFunction.Large(rgc, n) <> Application.WorksheetFunction.Large(rgc, n - 1) Then
    
46.     Set rg = rgc.Find(Application.WorksheetFunction.Large(rgc, n), , , xlWhole)
    
47. Else
    
48.     Set rg = rgc.FindNext(rg)
    
49. End If
    
50. maxc = rg.Column
    
51. Range(Cells(5, maxc), Cells(107, maxc)).Copy
    
52. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
53. k = k + 1
    
54. Next
    
55. Set rg = Nothing
    
56. [bd3].Activate
    
57. On Error GoTo 0
    
58. Application.ScreenUpdating = True
    
59. End Sub
    

复制代码

跳转到最佳答案楼层

yizhih

bb75308973 发表于 2012-3-12 20:16
测试看看

谢谢 bb75308973，就是有一个问题，无论是移动几列，A1区总是有两行重复的数据。

附件怎么删除，下面这个附件是多余的。

bb75308973

yizhih 发表于 2012-3-12 21:59
谢谢 bb75308973，就是有一个问题，无论是移动几列，A1区总是有两行重复的数据。

附件怎么删除，下面这 ...

明白了,代码有点问题我修改下

bb75308973

测试看看
列移动答案.zip (32.17 KB, 下载次数: 26)

2012-3-13 01:05 上传

点击文件名下载附件

1. Private Sub CommandButton1_Click()
   
2. Dim n As Integer, a As Integer, k As Integer
   
3. Dim rga As Range, rgb As Range, rgc As Range, rg As Range
   
4. Dim maxa As Integer, maxb As Integer, maxc As Integer
   
5. 
   
6. Application.ScreenUpdating = False
   
7. Range("BC5:BK107").ClearContents '清除原来的内容
   
8. Range("BM5:BU107").ClearContents
   
9. Range("BW5:CE107").ClearContents
   
10. a = [r2]
    
11. Set rga = Range("H107:Q107"): Set rgb = Range("U107:AD107"): Set rgc = Range("AG107:AQ107") '定义要取最大值的区域3个
    
12. On Error Resume Next
    
13. 'A区
    
14. k = 55
    
15. For n = 1 To a '取多少列就循环多少次
    
16. '如果第几大的值与前面一个不同就直接查找他的位置,如果相同等从上一个之后查找,这样就不会重复了
    
17. If Application.WorksheetFunction.Large(rga, n) <> Application.WorksheetFunction.Large(rga, n - 1) Then
    
18.     Set rg = rga.Find(Application.WorksheetFunction.Large(rga, n), , , xlWhole)
    
19. Else
    
20.     Set rg = rga.FindNext(rg)
    
21. End If
    
22. maxa = rg.Column
    
23. Range(Cells(5, maxa), Cells(107, maxa)).Copy '复制相应的列到相应的区域
    
24. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
25. k = k + 1
    
26. Next
    
27. Set rg = Nothing
    
28. 'B区
    
29. k = 65
    
30. For n = 1 To a
    
31. If Application.WorksheetFunction.Large(rgb, n) <> Application.WorksheetFunction.Large(rgb, n - 1) Then
    
32.     Set rg = rgb.Find(Application.WorksheetFunction.Large(rgb, n), , , xlWhole)
    
33. Else
    
34.     Set rg = rgb.FindNext(rg)
    
35. End If
    
36. maxb = rg.Column
    
37. Range(Cells(5, maxb), Cells(107, maxb)).Copy
    
38. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
39. k = k + 1
    
40. Next
    
41. Set rg = Nothing
    
42. 'C区
    
43. k = 75
    
44. For n = 1 To a
    
45. If Application.WorksheetFunction.Large(rgc, n) <> Application.WorksheetFunction.Large(rgc, n - 1) Then
    
46.     Set rg = rgc.Find(Application.WorksheetFunction.Large(rgc, n), , , xlWhole)
    
47. Else
    
48.     Set rg = rgc.FindNext(rg)
    
49. End If
    
50. maxc = rg.Column
    
51. Range(Cells(5, maxc), Cells(107, maxc)).Copy
    
52. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
53. k = k + 1
    
54. Next
    
55. Set rg = Nothing
    
56. [bd3].Activate
    
57. On Error GoTo 0
    
58. Application.ScreenUpdating = True
    
59. End Sub
    

复制代码

bb75308973

yizhih 发表于 2012-3-12 21:59
谢谢 bb75308973，就是有一个问题，无论是移动几列，A1区总是有两行重复的数据。

附件怎么删除，下面这 ...

代码及附件都更新了,你再看看

yizhih

bb75308973 发表于 2012-3-13 01:06
代码及附件都更新了,你再看看

非常感谢 bb75308973 老师，非常好，再次感谢！

bb75308973

再给你个简单快速的方法

1. Private Sub CommandButton1_Click()
   
2. Dim n As Integer, a As Integer, k As Integer, maxa As Integer, maxb As Integer, maxc As Integer
   
3. Dim rga As Range, rgb As Range, rgc As Range, rg As Range
   
4. Application.ScreenUpdating = False
   
5. '清除原来的内容
   
6. Range("BC5:BK107").ClearContents: Range("BM5:BU107").ClearContents: Range("BW5:CE107").ClearContents
   
7. a = [r2]: k = 55
   
8. '定义要取最大值的区域3个
   
9. Set rga = Range("H107:Q107"): Set rgb = Range("U107:AD107"): Set rgc = Range("AH107:AQ107"): Set rg = Range("A1")
   
10. 'On Error Resume Next
    
11. '取多少列就循环多少次
    
12. For n = 1 To a
    
13. '计算第几大的位置
    
14. maxa = Evaluate("=MATCH(LARGE(  " & rga.Address & "  *100+1/COLUMN( " & rga.Address & " )," & n & "), " & rga.Address & " *100+1/COLUMN( " & rga.Address & " ),0)") + 7
    
15. maxb = Evaluate("=MATCH(LARGE(  " & rgb.Address & "  *100+1/COLUMN( " & rgb.Address & " )," & n & "), " & rgb.Address & " *100+1/COLUMN( " & rgb.Address & " ),0)") + 20
    
16. maxc = Evaluate("=MATCH(LARGE(  " & rgc.Address & "  *100+1/COLUMN( " & rgc.Address & " )," & n & "), " & rgc.Address & " *100+1/COLUMN( " & rgc.Address & " ),0)") + 33
    
17. '复制相应的列到相应的区域
    
18. Range(Cells(5, maxa), Cells(107, maxa)).Copy
    
19. Range(Cells(5, k), Cells(107, k)).PasteSpecial xlPasteFormulas
    
20. Range(Cells(5, maxb), Cells(107, maxb)).Copy
    
21. Range(Cells(5, (k + 10)), Cells(107, (k + 10))).PasteSpecial xlPasteFormulas
    
22. Range(Cells(5, maxc), Cells(107, maxc)).Copy
    
23. Range(Cells(5, (k + 20)), Cells(107, (k + 20))).PasteSpecial xlPasteFormulas
    
24. k = k + 1
    
25. Next
    
26. [BD3].Activate
    
27. On Error GoTo 0
    
28. Application.ScreenUpdating = True
    
29. End Sub

复制代码

ztccsj

bb75308973 发表于 2012-3-12 20:16
测试看看

这么复杂啊，佩服编程