悬赏-5元求个代码。。

鄂龙蒙

1. Sub 行排序()
   
2.     Cells.ClearContents
   
3.     Dim i, j, arr, br(), cr()
   
4.     arr = Sheet1.Range("A1:Z" & Sheet1.[A65536].End(3).Row)
   
5.     ReDim br(1 To 1, 1 To UBound(arr, 2) - 2)
   
6.     ReDim cr(1 To UBound(arr, 2) - 2)
   
7.     For i = 2 To UBound(arr)
   
8.         For j = 3 To UBound(arr, 2)
   
9.             br(1, j - 2) = arr(i, j)
   
10.         Next
    
11.         For j = 1 To UBound(br, 2)
    
12.             cr(j) = Application.Large(br, j)
    
13.         Next
    
14.         For j = 3 To UBound(arr, 2)
    
15.             arr(i, j) = cr(j - 2)
    
16.         Next
    
17.     Next
    
18.     [A1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
19. End Sub

复制代码

鄂龙蒙

数据处理.rar (558.76 KB, 下载次数: 20)

2019-8-23 21:16 上传

点击文件名下载附件

小花鹿

楼主土豪                                                                                                              

daihao3018

新手试做一下

1. Sub 排序()
   
2.     Dim i, j, m,n As Integer
   
3.     Dim d As Object
   
4.     Dim arr, brr
   
5.     m = Range("a65535").End(3).Row
   
6.     For n = 1 To m
   
7.         Cells(2 * n, 1).Select
   
8.         Selection.EntireRow.Insert
   
9.     Next n
   
10.    
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     m = Range("a65535").End(3).Row
    
13.    
    
14.     For n = 3 To m Step 2
    
15.         arr = Application.Transpose(Cells(n, 3).Resize(1, 24))
    
16.         
    
17.         For i = 1 To UBound(arr)
    
18.             d(arr(i, 1)) = ""
    
19.         Next
    
20.         
    
21.         ReDim brr(1 To d.Count + 1)
    
22.         brr = d.keys
    
23.         
    
24.         Count = UBound(brr)
    
25.         For i = 0 To Count - 1
    
26.             For j = i + 1 To Count
    
27.                
    
28.                 If brr(i) > brr(j) Then
    
29.                     Temp = brr(i)
    
30.                     brr(i) = brr(j)
    
31.                     brr(j) = Temp
    
32.                 End If
    
33.             Next j
    
34.         Next i
    
35.         
    
36.         For i = 0 To UBound(brr)
    
37.             For j = 3 To 26
    
38.                 If Cells(n, j) = brr(i) Then
    
39.                     Cells(n - 1, j) = i + 1
    
40.                     Cells(n - 1, j).Font.Bold = True
    
41.                 End If
    
42.             Next
    
43.         Next
    
44.         
    
45.         Erase arr, brr
    
46.         d.RemoveAll
    
47.     Next
    
48.    
    
49. End Sub

复制代码

oclassic123

谢谢大家。第一个加我q发我的已经给我解决啦。谢谢所有人啦

oclassic123

一把小刀闯天下 发表于 2019-8-23 21:07
'试了一下，第一行第一个数示例就是错的，应该为14

'好玩而已，跟金币无关。仅处理了一张表格，，，

谢谢谢谢。谢谢大哥了。

oclassic123

鄂龙蒙 发表于 2019-8-23 21:16

谢谢哥，下次q发我。。。我再加点钱。5快有点少

oclassic123

一把小刀闯天下 发表于 2019-8-23 21:07
'试了一下，第一行第一个数示例就是错的，应该为14

'好玩而已，跟金币无关。仅处理了一张表格，，，

谢谢，我去试试

鄂龙蒙

oclassic123 发表于 2019-8-23 22:30
谢谢哥，下次q发我。。。我再加点钱。5快有点少

给您参考，能符合要求就好。