'可以不上附件，不过自己要会修改，需修改的地方都做了注释
'前面代码的效率极差，你的数据量可能较大所以给你重写了，效率优先
'当然满意要来朵小花的哦
Option Explicit
Const TITLENUM = 1 '标题行数量，这里为1行，修改
Const COL_1 = 1, COL_2 = 2 '"条件1"、"条件2"的对应的列号，修改
Const FINDSTR = "甲" '查找的字符串，修改
Sub test()
Dim i, j, pos(1), arr, brr
arr = Sheets("sheet1").[a1].CurrentRegion '源数据工作表及位置
brr = arr: pos(0) = TITLENUM: pos(1) = UBound(arr, 1) + 1
For i = TITLENUM + 1 To UBound(arr, 1)
If arr(i, COL_1) = FINDSTR Then
pos(1) = pos(1) - 1
For j = 1 To UBound(arr, 2): brr(pos(1), j) = arr(i, j): Next
Else
pos(0) = pos(0) + 1
For j = 1 To UBound(arr, 2): brr(pos(0), j) = arr(i, j): Next
End If
Next
Call msort(brr, arr, TITLENUM + 1, pos(0), 1, UBound(brr, 2), COL_2)
Call msort(brr, arr, pos(1), UBound(brr, 1), 1, UBound(brr, 2), COL_2)
Sheets("sheet2").[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr '输出工作表及位置
End Sub
Function msort(arr, temp, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, kk As Long, mid As Long
If first <> last Then
mid = Int((first + last) / 2)
msort arr, temp, first, mid, left, right, key
msort arr, temp, mid + 1, last, left, right, key
i = first: j = mid + 1: k = first
While i <= mid And j <= last
If arr(i, key) >= arr(j, key) Then
For kk = left To right: temp(k, kk) = arr(i, kk): Next
k = k + 1: i = i + 1
Else
For kk = left To right: temp(k, kk) = arr(j, kk): Next
k = k + 1: j = j + 1
End If
Wend
While i <= mid
For kk = left To right: temp(k, kk) = arr(i, kk): Next
k = k + 1: i = i + 1
Wend
While j <= last
For kk = left To right: temp(k, kk) = arr(j, kk): Next
k = k + 1: j = j + 1
Wend
For i = first To last
For j = left To right
arr(i, j) = temp(i, j)
Next j, i
End If
End Function |
楼主: hugh1236
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2018-7-26 18:40
