Excel vba按字母顺序循环范围

Question

我想按字母顺序遍历一系列单元格以按字母顺序创建报告。我不想对工作表进行排序，因为原始顺序很重要。

Sub AlphaLoop()

'This is showing N and Z in uppercase, why?
For Each FirstLetter In Array(a, b, c, d, e, f, g, h, i, j, k, l, m, N, o, p, q, r, s, t, u, v, w, x, y, Z)
    For Each SecondLetter In Array(a, b, c, d, e, f, g, h, i, j, k, l, m, N, o, p, q, r, s, t, u, v, w, x, y, Z)
        For Each tCell In Range("I5:I" & Range("I20000").End(xlUp).Row)
            If Left(tCell, 2) = FirstLetter & SecondLetter Then
                'Do the report items here
        End If
        Next
    Next
Next

End Sub

请注意，此代码未经测试，仅按前 2 个字母排序，并且非常耗时，因为它必须遍历文本 676 次。还有比这更好的方法吗？

Answer 1

尝试从不同的角度接近。

将范围复制到新工作簿

使用 Excel 排序功能对复制的范围进行排序

将排序后的范围复制到数组中

关闭临时工作簿而不保存

使用 Find 函数循环数组以按顺序定位值并运行您的代码。

如果您在编写本文时需要帮助，请回帖，但应该相当简单。您需要将范围转置为数组，并且需要将数组调暗为变体。

这样你只有一个循环，使用嵌套循环会使它们呈指数级增长

Answer 2

也许创建额外的列，其中包含从 1 到您需要的最大值的数字（以记住顺序），然​​后使用 Excel 的排序按您的列排序，做您的事情，按第一个创建的列重新排序（重新排序），然后删除该列专栏

Answer 3

您可以将实际的报告生成例程移至另一个子程序，并在循环通过一系列排序匹配时从第一个子程序调用它。

Sub AlphabeticLoop()
    Dim fl As Integer, sl As Integer, sFLTR As String, rREP As Range

    With ActiveSheet   'referrence this worksheet properly!
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Range(.Cells(4, 9), .Cells(Rows.Count, 9).End(xlUp))
            For fl = 65 To 90
                For sl = 65 To 90
                    sFLTR = Chr(fl) & Chr(sl) & Chr(42)
                    If CBool(Application.CountIf(.Columns(1).Offset(1, 0), sFLTR)) Then
                        .AutoFilter field:=1, Criteria1:=sFLTR
                        With .Offset(1, 0).Resize(.Rows.Count - 1, 1)
                            For Each rREP In .SpecialCells(xlCellTypeVisible)
                                report_Do rREP.Parent, rREP, rREP.Value
                            Next rREP
                        End With
                        .AutoFilter field:=1
                    End If
                Next sl
            Next fl
        End With
    End With
End Sub

Sub report_Do(ws As Worksheet, rng As Range, val As Variant)
    Debug.Print ws.Name & " - " & rng.Address(0, 0, external:=True) & " : " & val
End Sub

此代码应该在您现有的数据上运行，以升序将可用的报告值列出到 VBE 的即时窗口。

可以通过另一个嵌套的 For/Next 轻松添加额外级别的升序排序，并将新字母连接到 Chr(42)..之前的 sFLTR 变量。

Answer 4

一个选项是创建一个值数组，快速排序数组，然后迭代排序后的数组以创建报告。即使源数据中存在重复项（已编辑），这仍然有效。

范围和结果图片在左侧框中显示数据，在右侧显示排序后的“报告”。我的报告只是从原始行复制数据。此时你可以做任何事情。我在事后添加了颜色以显示对应关系。

代码遍历数据索引，对值进行排序，然后再次遍历它们以输出数据。它使用Find/FindNext 从排序后的数组中获取原始项目。

Sub AlphabetizeAndReportWithDupes()

    Dim rng_data As Range
    Set rng_data = Range("B2:B28")

    Dim rng_output As Range
    Set rng_output = Range("I2")

    Dim arr As Variant
    arr = Application.Transpose(rng_data.Value)
    QuickSort arr
    'arr is now sorted

    Dim i As Integer
    For i = LBound(arr) To UBound(arr)

        'if duplicate, use FindNext, else just Find
        Dim rng_search As Range
        Select Case True
            Case i = LBound(arr), UCase(arr(i)) <> UCase(arr(i - 1))
                Set rng_search = rng_data.Find(arr(i))
            Case Else
                Set rng_search = rng_data.FindNext(rng_search)
        End Select

        ''''do your report stuff in here for each row
        'copy data over
        rng_output.Offset(i - 1).Resize(, 6).Value = rng_search.Resize(, 6).Value

    Next i
End Sub

'from https://stackoverflow.com/a/152325/4288101
'modified to be case-insensitive and Optional params
Public Sub QuickSort(vArray As Variant, Optional inLow As Variant, Optional inHi As Variant)

    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long

    If IsMissing(inLow) Then
      inLow = LBound(vArray)
    End If

    If IsMissing(inHi) Then
      inHi = UBound(vArray)
    End If

    tmpLow = inLow
    tmpHi = inHi

    pivot = vArray((inLow + inHi) \ 2)

    While (tmpLow <= tmpHi)

       While (UCase(vArray(tmpLow)) < UCase(pivot) And tmpLow < inHi)
          tmpLow = tmpLow + 1
       Wend

       While (UCase(pivot) < UCase(vArray(tmpHi)) And tmpHi > inLow)
          tmpHi = tmpHi - 1
       Wend

       If (tmpLow <= tmpHi) Then
          tmpSwap = vArray(tmpLow)
          vArray(tmpLow) = vArray(tmpHi)
          vArray(tmpHi) = tmpSwap
          tmpLow = tmpLow + 1
          tmpHi = tmpHi - 1
       End If

    Wend

    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub

代码注释：

• 我已从该previous answer 获取快速排序代码，并将UCase 添加到不区分大小写搜索的比较中，并设置了参数Optional（和Variant 以使其正常工作）。
• Find/FindNext 部分正在遍历原始数据并在其中定位已排序的项目。如果找到重复项（即，如果当前值与之前的值匹配），那么它将使用 FindNext 从之前找到的条目开始。
• 我的报告生成只是从数据表中获取值。 rng_search 保存原始数据源中当前项的Range。
• 我正在使用Application.Tranpose 强制.Value 成为1-D 数组，而不是像正常的多暗淡。见this answer for that usage。如果要再次输出到列中，请再次转置数组。
• Select Case 位只是在 VBA 中进行短路评估的一种简单方法。有关它的用法，请参阅 this previous answer。

Answer 5

这是 Dan Donoghue 在代码中的想法。您可以通过在排序之前存储数据的原始顺序来完全跳过使用慢查找功能。

Sub ReportInAlphabeticalOrder()

    Dim rng As Range
    Set rng = Range("I5:I" & Range("I20000").End(xlUp).row)

    ' copy data to temp workbook and sort alphabetically
    Dim wbk As Workbook
    Set wbk = Workbooks.Add
    Dim wst As Worksheet
    Set wst = wbk.Worksheets(1)
    rng.Copy wst.Range("A1")
    With wst.UsedRange.Offset(0, 1)
        .Formula = "=ROW()"
        .Calculate
        .Value2 = .Value2
    End With
    wst.UsedRange.Sort Key1:=wst.Range("B1"), Header:=xlNo

    ' transfer alphabetized row indexes to array & close temp workbook
    Dim Indexes As Variant
    Indexes = wst.UsedRange.Columns(2).Value2
    wbk.Close False

    ' create a new worksheet for the report
    Set wst = ThisWorkbook.Worksheets.Add
    Dim ReportRow As Long
    Dim idx As Long
    Dim row As Long
    ' loop through the array of row indexes & create the report
    For idx = 1 To UBound(Indexes)
        row = Indexes(idx, 1)
        ' take data from this row and put it in the report
        ' keep in mind that row is relative to the range I5:I20000
        ' offset it as necessary to reference cells on the same row
        ReportRow = ReportRow + 1
        wst.Cells(ReportRow, 1) = rng(row)
    Next idx

End Sub