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

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

Answer 1

尝试从不同的角度接近。

将范围复制到新工作簿

使用Excels排序功能

对复制的范围进行排序

将已排序的范围复制到数组

关闭临时工作簿而不保存

使用Find函数循环数组，按顺序查找值并运行代码。

如果你需要帮助写这篇文章可以回复，但它应该相当简单。您需要将范围转置到数组，并且需要将数组调暗为变体。

这样你只有一个循环，使用嵌套循环以指数方式将它们吹出

Answer 2

这是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

Answer 3

也许创建额外的列，其中包含从1到最大的数字（记住顺序），然后按列排序，使用Excel排序，执行操作，通过首先创建的列重新排序（排序），然后删除柱

Answer 4

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

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 5

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

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

results of sorting

代码运行数据索引，对值进行排序，然后再次运行它们以输出数据。它正在使用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。

Excel vba按字母顺序循环显示范围

5 个答案: