Excel 利用VBA自动排序的问题

hugh1236

1表为原表，需将排序按2表排序

条件1	条件2
乙	1
甲	2
乙	5
丙	3
甲	3
丙	6
甲	1
乙	4
丙	2

条件1	条件2
丙	6
乙	5
乙	4
丙	3
丙	2
乙	1
甲	3
甲	2
甲	1

条件1：将条件为“甲”的数据排在最后，其余条件不排序

条件2：数值按降序排列

请各位大侠帮帮忙，急！谢谢！！！
                                                              

hugh1236

求求各位大佬帮忙研究下啊 T_T

microyip

这个不用研究的呀，做两个字典，一个是“甲”字典，一个是非甲字典，关键字用 条件2+条件1，对关键字进行排序重新读取放数组里即可

hugh1236

microyip 发表于 2018-7-26 12:05
这个不用研究的呀，做两个字典，一个是“甲”字典，一个是非甲字典，关键字用 条件2+条件1，对关键字进行排 ...

能具体点吗？我属小白系列

jnsxmt

1. Sub test()
   
2.     Dim ar, m&, n&, k&, stra, strb
   
3.     Range(Range("f15"), Cells(Rows.Count, "g").End(xlUp)).ClearContents
   
4.     ar = Range(Range("a2"), Cells(Rows.Count, "a").End(xlUp).Offset(0, 1))
   
5.     For m = LBound(ar, 1) To UBound(ar, 1)
   
6.         For n = m + 1 To UBound(ar, 1)
   
7.             If ar(m, 1) <> "甲" Then
   
8.                 If ar(n, 1) <> "甲" Then
   
9.                 If ar(m, 2) < ar(n, 2) Then
   
10.                     stra = ar(m, 1): strb = ar(m, 2)
    
11.                     ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
12.                     ar(n, 1) = stra: ar(n, 2) = strb
    
13.                 End If
    
14.                 End If
    
15.             Else
    
16.                 If ar(n, 1) <> "甲" Then
    
17.                     stra = ar(m, 1): strb = ar(m, 2)
    
18.                     ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
19.                     ar(n, 1) = stra: ar(n, 2) = strb
    
20.                 ElseIf ar(n, 1) = "甲" Then
    
21.                     If ar(m, 2) < ar(n, 2) Then
    
22.                         stra = ar(m, 1): strb = ar(m, 2)
    
23.                         ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
24.                         ar(n, 1) = stra: ar(n, 2) = strb
    
25.                     End If
    
26.                 End If
    
27.             End If
    
28.         Next
    
29.     Next
    
30.     Range("f15").Resize(UBound(ar, 1), 2) = ar
    
31. End Sub

复制代码

duquancai

mark一下     

魂断蓝桥

Sub 查询()
Dim cnn As Object
Dim Sql As String
Set cnn = CreateObject("ADODB.CONNECTION")
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select * from [Sheet1$a1:b10] ORDER BY INSTR('甲',条件1) asc,条件2 desc"
[i2].CopyFromRecordset cnn.Execute(Sql)
cnn.Close: Set cnn = Nothing
End Sub

hugh1236

jnsxmt 发表于 2018-7-26 13:13

不好意思，直接用不了，也没怎么懂这段代码。
Range(Range("f15"), Cells(Rows.Count, "g").End(xlUp)).ClearContents
这是有在用表2的数据吗？
表2是我想达到的目的，实际表中是没这东西的，需要将多行的数据按表2这种要求排序

一把小刀闯天下

hugh1236 发表于 2018-7-26 12:20
能具体点吗？我属小白系列

Option Explicit

Sub test()
  Dim i, j, pos, arr, t
  arr = [a1].CurrentRegion
  For i = UBound(arr, 1) To 2 Step -1
    If arr(i, 1) = "甲" Then
      For j = i - 1 To 2 Step -1
        If arr(j, 1) <> "甲" Then pos = j: Exit For
      Next
      For j = pos To 2 Step -1
        If arr(j, 1) = "甲" Then
          t = arr(pos, 1): arr(pos, 1) = arr(j, 1): arr(j, 1) = t
          t = arr(pos, 2): arr(pos, 2) = arr(j, 2): arr(j, 2) = t
          i = pos: Exit For
        End If
      Next
    Else
      For j = i To 2 Step -1
        If arr(j, 1) = "甲" Then
          t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
          t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
          Exit For
        End If
      Next
    End If
  Next
  For i = 2 To UBound(arr, 1)
    If arr(i, 1) = "甲" Then pos = i: Exit For
  Next
  For i = 2 To pos - 2
    For j = i + 1 To pos - 1
      If arr(i, 2) < arr(j, 2) Then
        t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
        t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
      End If
  Next j, i
  For i = pos To UBound(arr, 1) - 1
    For j = i + 1 To UBound(arr, 1)
      If arr(i, 2) < arr(j, 2) Then
        t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
        t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
      End If
  Next j, i
  [m1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr '作比较用，自己修改
End Sub

jnsxmt

把代码放入模块里，运行即可

1. Sub test()
   
2.     Dim ar, m&, n&, k&, stra, strb
   
3.     ar = Sheet1.Range(Sheet1.Range("a2"), Sheet1.Cells(Sheet1.Rows.Count, "a").End(xlUp).Offset(0, 1))
   
4.     For m = LBound(ar, 1) To UBound(ar, 1)
   
5.         For n = m + 1 To UBound(ar, 1)
   
6.             If ar(m, 1) <> "甲" Then
   
7.                 If ar(n, 1) <> "甲" Then
   
8.                 If ar(m, 2) < ar(n, 2) Then
   
9.                     stra = ar(m, 1): strb = ar(m, 2)
   
10.                     ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
11.                     ar(n, 1) = stra: ar(n, 2) = strb
    
12.                 End If
    
13.                 End If
    
14.             Else
    
15.                 If ar(n, 1) <> "甲" Then
    
16.                     stra = ar(m, 1): strb = ar(m, 2)
    
17.                     ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
18.                     ar(n, 1) = stra: ar(n, 2) = strb
    
19.                 ElseIf ar(n, 1) = "甲" Then
    
20.                     If ar(m, 2) < ar(n, 2) Then
    
21.                         stra = ar(m, 1): strb = ar(m, 2)
    
22.                         ar(m, 1) = ar(n, 1): ar(m, 2) = ar(n, 2)
    
23.                         ar(n, 1) = stra: ar(n, 2) = strb
    
24.                     End If
    
25.                 End If
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     Sheet2.UsedRange.Offset(1, 0).ClearContents
    
30.     Sheet2.[a2].Resize(UBound(ar, 1), 2) = ar
    
31. End Sub

复制代码