【已解决，感谢baofa2】用VBA进行排序：一个sheet中很多个表，每个表单独排序

flb_2001

数据样式如下：

品名	参与单位数	V1	V2	V3
A	2	×	○
A	1	○
A	1		○
A	2		○	×
A	2	×	○
品名	参与单位数	V9	V6	V5	V7	V8	V4
B	2			○	×
B	2			○			×
B	2			○		×
B	1		○
B	3	×		○			×

要求：1.品名A和B分别排序。2.排序第一个字段为参与单位数（升序），接下去的排序字段按顺序分别是V1，V2，V3....排序字段取决于实际V的个数。

flb_2001

哪位大佬帮帮忙，指点下！！！

chxw68

flb_2001 发表于 2024-4-28 10:13
哪位大佬帮帮忙，指点下！！！

上传附件。

flb_2001

chxw68 发表于 2024-4-28 10:16
上传附件。

公司没发上传附件，加密的

baofa2

1. Sub test0() '类似案例，若不行则要有附件，改一下加上单位数排序
   
2.   Dim ar, br() As Long
   
3.   Dim i As Long, j As Long, k As Long, p As Long
   
4.   ar = Range("A1").CurrentRegion
   
5.   p = UBound(ar)
   
6.   For i = UBound(ar) To 1 Step -1
   
7.     If ar(i, 1) = "品名" Then
   
8.       k = 2
   
9.       For j = 3 To UBound(ar, 2)
   
10.         If Len(ar(i, j)) Then
    
11.           k = k + 1
    
12.           ReDim Preserve br(1 To k)
    
13.           br(k) = Val(Mid(ar(i, j), 2))
    
14.         Else
    
15.           Exit For
    
16.         End If
    
17.       Next
    
18.       BubbleSort ar, i + 1, p, 1, k, 2
    
19.       QuickSort ar, br, i, p, 3, k
    
20.       p = i - 1
    
21.     End If
    
22.   Next
    
23.   Range("L1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
24.   Beep
    
25. End Sub
    
26. 
    
27. Function BubbleSort(ar, t As Long, b As Long, l As Long, r As Long, k As Long)
    
28.   Dim i As Long, x As Long, y As Long, swap, Flag As Boolean
    
29.   For i = t To b - 1
    
30.     Flag = True
    
31.     For y = t To b + t - 1 - i
    
32.       If ar(y, k) > ar(y + 1, k) Then
    
33.         Flag = False
    
34.         For x = l To r
    
35.           swap = ar(y, x)
    
36.           ar(y, x) = ar(y + 1, x)
    
37.           ar(y + 1, x) = swap
    
38.         Next
    
39.       End If
    
40.     Next
    
41.     If Flag Then Exit For
    
42.   Next
    
43. End Function
    
44. 
    
45. Function QuickSort(ar, br, t As Long, b As Long, l As Long, r As Long)
    
46.   Dim i As Long, j As Long, x As Long, y As Long, pivot As Long, swap
    
47.   j = l
    
48.   x = r
    
49.   pivot = br((l + r) \ 2)
    
50.   While j <= x
    
51.     Do
    
52.       If br(j) < pivot Then j = j + 1 Else Exit Do
    
53.     Loop While j < r
    
54.     Do
    
55.       If pivot < br(x) Then x = x - 1 Else Exit Do
    
56.     Loop While x > l
    
57.     If j < x Then
    
58.       swap = br(j): br(j) = br(x): br(x) = swap
    
59.       For y = t To b
    
60.         swap = ar(y, j): ar(y, j) = ar(y, x): ar(y, x) = swap
    
61.       Next
    
62.       j = j + 1: x = x - 1
    
63.     Else
    
64.       If j = x Then j = j + 1: x = x - 1
    
65.     End If
    
66.   Wend
    
67.   If l < x Then QuickSort ar, br, t, b, l, x
    
68.   If j < r Then QuickSort ar, br, t, b, j, r
    
69. End Function

复制代码

ykcbf1100

这个排序不能用常规排序法，没有附件，不好弄

3190496160

上传附件应该可以解决，但是，没有附件就没有办法

flb_2001

baofa2 发表于 2024-4-28 10:25

谢谢大佬，可以跑，但我忘了说明，需要在原位置进行排序，这样格式不用变

flb_2001

ykcbf1100 发表于 2024-4-28 11:16
这个排序不能用常规排序法，没有附件，不好弄

你可以拷贝这个到excel

flb_2001

3190496160 发表于 2024-4-28 11:49
上传附件应该可以解决，但是，没有附件就没有办法

我提问的那个是表格，直接复制到excel就行