常用代码——数组相关

Index2

Rem 取二维数组的某个范围的数据，结果为二维数组(下标从1开始)
Rem 除可提取整行、整列外 更可提取任意行列位置起始的多行多列矩形局域
Rem 第1参数trr： 为引用的VBA内存一维或二维数组如arr 或[工作表区域].Value的二维结构数组
Rem 第2、3参数r 和c：可省略。默认值=0即整行、整列，否则为数组起点开始的行、列相对位置
Rem 第4、5参数h 和 w：该参数可省略。 默认值=-1即输出一维数组 否则按指定值进行多行、多列的二维数组输出
Function Index2(trr, Optional r = 0, Optional c = 0, Optional h = -1, Optional w = -1)
    Dim tr()
    Dim c2, r2, i, j
    If r And h = -1 Then
        c = LBound(trr, 2): c2 = UBound(trr, 2)
        ReDim tr(1 To 1, 1 To c2 + c - 1)
        For j = c To c2
            tr(1, j - c + 1) = trr(r, j)
        Next
        Index2 = tr
    ElseIf c And w = -1 Then
        r = LBound(trr): r2 = UBound(trr)
        ReDim tr(1 To r2 + r - 1, 1 To 1)
        For i = r To r2
            tr(i - r + 1, 1) = trr(i, c)
        Next
        Index2 = tr
    Else
        If r = 0 Then r = LBound(trr)
        If c = 0 Then c = LBound(trr, 2)
        If h > 0 Then r2 = r + h - 1 Else r2 = UBound(trr)
        If w > 0 Then c2 = c + w - 1 Else c2 = UBound(trr, 2)
        If r2 > UBound(trr) Then r2 = UBound(trr)
        If c2 > UBound(trr, 2) Then c2 = UBound(trr, 2)
        ReDim tr(1 To r2 - r + 1, 1 To c2 - c + 1)
        For i = r To r2
            For j = c To c2
                tr(i - r + 1, j - c + 1) = trr(i, j)
            Next
        Next
        Index2 = tr
    End If
End Function

Transpose2

'转置数组
Function Transpose2(ByVal vData As Variant) As Variant

    Dim vNewData As Variant, nRow As Double, nCol As Double
   
    If IsArray(vData) Then
        ReDim vNewData(1 To UBound(vData, 2) - LBound(vData, 2) + 1, 1 To UBound(vData) - LBound(vData) + 1)
        For nRow = 1 To UBound(vNewData)
            For nCol = 1 To UBound(vNewData, 2)
                If Not IsNull(vData(nCol + LBound(vData, 2) - 1, nRow + LBound(vData) - 1)) Then _
                    vNewData(nRow, nCol) = vData(nCol + LBound(vData, 2) - 1, nRow + LBound(vData) - 1)
            Next
        Next
        vData = vNewData
    End If
    Transpose2 = vData
End Function

二维数组工作表排序

'第1参数ar：为待排序二维数组
'第2参数h：为不参与排序的标题行的行数
'第3参数sr：为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。
Function RngSort(ByVal ar, h&, ParamArray sr())
    Dim sht As Worksheet, i As Long
    Dim sr2
    On Error Resume Next
    Set sht = ThisWorkbook.Worksheets("tmpShtSort")
    If sht Is Nothing Then
        With ThisWorkbook.Sheets.Add
            .Name = "tmpShtSort"
            .Visible = xlSheetVeryHidden
        End With
        Set sht = ThisWorkbook.Worksheets("tmpShtSort")
    End If
    If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr
    With sht
        .Range("a1").Resize(UBound(ar), UBound(ar, 2)) = ar
        For i = UBound(sr2) To LBound(sr2) Step -2
            With .Range("a" & h + 1).Resize(UBound(ar) - h, UBound(ar, 2))
                .Sort .Range(sr2(i - 1) & h + 1), sr2(i), , , , , , xlNo
            End With
        Next i
        RngSort = .Range("a1").Resize(UBound(ar), UBound(ar, 2))
        .Cells.Clear
    End With
End Function

二维数组稳定排序

Rem  sr = Array(3, 1, 5, 2, 7, 1) '按权重优先顺序key、Sort值交替排列的一维数组。key为列序号、Sort值：1升序、2降序
'    sr = Array(3, -1, 5, 2, 7, -1)'Sort值=-1时，升序并且空值会在最前面。(Sort=1时按工作表排序方法空值排在最后)
                                   'Sort值=2时、降序而空值自然会在最后。
'    br = szpx(ar, 0, sr) '第1参数为待排序二维数组、第2参数为不参与排序的标题行的行数
                          '第3参数为按权重优先顺序key、Sort值交替排列的一维数组。
'    br = szpx(ar, 0, 3, 1, 5, 2, 7, 1) '也可这样写入参数。从第3个参数开始交替写入key、Sort值。推荐第1种写法。
'    下面是返回排序后数组结果,并输出到工作表的代码
'    [a1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br

Function szpx(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 主要参考借鉴了Zamyi大侠的二维数组多key排序算法
    '第1参数ar：为待排序二维数组
    '第2参数h：为不参与排序的标题行的行数
    '第3参数sr：为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。
    
    Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t
    
    l = LBound(ar) + h: u = UBound(ar) '获取数组起始、结束位置
    ReDim x&(l To u), z(l To u + 1) As Boolean '定义存放Index序号的数组x、标记段落结束位置的数组z
    For i = l To u
        x(i) = i 'Index赋值为数组行序号、这以后排序就只需改变这个Index位置、原始数组无需改变
    Next
    z(u + 1) = True '标记最后结束位置
    
    If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr '判断第3参数是数组、还是多Key、Sort值序列
    j = sr2(0): If sr2(1) Mod 2 Then Call QuickSort1(ar, x, j, l, u) Else Call QuickSort2(ar, x, j, l, u)
    '按key1先进行QuickSort排序
    If sr2(1) = 1 Then Call AZE(ar, x, j, l, u) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
    
    For k = 2 To UBound(sr2) Step 2 '接着循环继续key2以后的排序
'        br = szbr(ar, x, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
        j2 = sr2(k): s = sr2(k + 1) '读取排序key的列序号j2 和Sort值s
        i = l: t = ar(x(i), j): i2 = i 'Do循环检查是否前key相同【注意，仅仅前key相同部分需要继续排序】
        Do
            Do
                i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
                '递增检查如果到了前前key的结束位置、或前key不同则停止退出Do循环
            Loop
            If i2 - i > 1 Then '如果间隔>1 则本key需要排序处理【注意排序区间是小范围i,i2-1】
                If s Mod 2 Then Call QuickSort1(ar, x, j2, i, i2 - 1) Else Call QuickSort2(ar, x, j2, i, i2 - 1)
                If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
            End If
            If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续从i2重新开始Do循环
        Loop
        j = j2 '更新前key列位置j
    Next
    
    '全部排序循环结束后、为保证最后的排序稳定性、检查最后的key值相同时必须按Index值排序。
    i = l: t = ar(x(i), j): i2 = i
    Do
        Do
            i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then Exit Do '检查方法相同
        Loop
        If i2 - i > 1 Then Call QuickSort(x, i, i2 - 1) '如果间隔>1 则Index值需要排序处理
        If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续
    Loop

'    szpx = x '多key稳定排序处理结束、返回排序结果的Index数组x
    szpx = szbr(ar, x, h) '或返回按排序后Index顺序引用返回的排序结果数组br
End Function
Function QuickSort(x, l&, u&) 'A-Z QuickSort '最后稳定排序时对相同key的Index值升序排序
    Dim i&, j&, n&, r&
    i = l: j = u: r = x((l + u) \ 2)
    While i < j
        While x(i) < r: i = i + 1: Wend 'A-Z
        While x(j) > r: j = j - 1: Wend 'A-Z
        If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort(x, l, j)
    If i < u Then Call QuickSort(x, i, u)
End Function
Function QuickSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort 按原数组j2列对应内容进行升序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) < r And i < u: i = i + 1: Wend   'A-Z
        While ar(x(j), j2) > r And j > l: j = j - 1: Wend   'A-Z
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort1(ar, x, j2, l, j)
    If i < u Then Call QuickSort1(ar, x, j2, i, u)
End Function
Function QuickSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort 按原数组j2列对应内容进行降序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A
        While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort2(ar, x, j2, l, j)
    If i < u Then Call QuickSort2(ar, x, j2, i, u)
End Function
Function AZE(ar, x, j, l&, u&) 'Sort值=1时、把排序完成后的空值移动到最后
    Dim i&, i2&, y
    For i = l To u
        If ar(x(i), j) <> "" Then '检查直到非空位置时停止
            y = x '复制Index数组x到y
            For i2 = l To i - 1
                x(u - i + i2 + 1) = y(i2) '前面的空值对应Index值移动到最后
            Next
            For i2 = i To u
                x(i2 - i + l) = y(i2) '后面的非空值对应Index值移动到前面
            Next
            Exit For
        End If
    Next
End Function
Function szbr(ar, nr, h&) 'Output Result Array 按排序后nr数组顺序、引用原数组对应Index值各列返回数组排序结果
    Dim br, i&, i2&, j2&, l&, l2&, u&, u2&
    l = LBound(ar) + h: u = UBound(ar)
    l2 = LBound(ar, 2): u2 = UBound(ar, 2)
    br = ar
    For i = l To u
        i2 = nr(i) '引用原数组对应Index值
        For j2 = l2 To u2
            br(i, j2) = ar(i2, j2) '按排序结果引用原数组对应值返回
        Next
    Next
    szbr = br
End Function

获取数组维数

Function GetArrayW(Ar As Variant) As Long
    If Not VBA.IsArray(Ar) Then
        GetArrayW = 0
        Exit Function
    End If
    
    On Error Resume Next
    Dim t As Long
    GetArrayW = -1
    Do Until Err.Number <> 0
        GetArrayW = GetArrayW + 1
        t = UBound(Ar, GetArrayW + 1)
    Loop
    On Error GoTo 0
End Function