Excel vba loop through range alphabetically

Question

I want to loop through a range of cells alphabetically to create a report in alphabetical order. I dont want to sort the sheet as the original order is important.

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

Note that this code is untested, only sorts by the first 2 letters and is time consuming as it has to loop through the text 676 times. Is there a better way than this?

Answer 1

Here's Dan Donoghue's idea in code. You can skip using the slow Find function completely by storing the original order of the data before you sort it.

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 2

One option is to create an array of the values, quick sort the array, and then iterate the sorted array to create the report. This works even if there are duplicates in the source data (edited).

Picture of ranges and results shows the data in the left box and the sorted "report" on the right. My report is just copying the data from the original row. You could do whatever at this point. I added the coloring after the fact to show the correspondence.

Code runs through the data index, sorts the values, and then runs through them again to output the data. It is using Find/FindNext to get the original item from the sorted array.

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

Notes on the code:

• I have taken the Quick Sort code from this previous answer and added UCase to the comparisons for case-insensitive searching and made parameters Optional (and Variant for that to work).
• The Find/FindNext part is going through the original data and locating the sorted items therein. If a duplicate is found (that is, if the current value matches the previous value) then it uses FindNext starting at the previously found entry.
• My report generation is just taking the values from the data table. rng_search holds the Range of the current item in the original data source.
• I am using Application.Tranpose to force .Value to be a 1-D array instead of the multi-dim like normal. See this answer for that usage. Transpose the array again if you want to output into a column again.
• The Select Case bit is just a hacky way of doing short-circuit evaluation in VBA. See this previous answer about the usage of that.

Answer 3

You might move your actual report generation routine to another sub and call it it from the first as you cycle through a series of sorted matches.

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

This code should run on your existing data, listing the available report values in an ascending order to the VBE's Immediate window.

An extra level of ascending sort could easily be added with another nested For/Next and a concatenating the new letter to the sFLTR variable before Chr(42)..

Answer 4

Maybe create extra column with numbers from 1 to maximum you need (to remember order), then sort by your column with Excel's sort, do your things, re-sort by firstly created column (to sort back), and delete that column

Answer 5

Try approaching from a different angle.

Copy the range to a new workbook

Sort the copied range using Excels sort function

Copy the sorted range to an array

Close the temp workbook without saving

Loop the array using the Find function to locate the value in order and run your code.

Post back if you need help writing this but it should be fairly simple. You will need to transpose the range to the array and you will need to dim your array as a variant.

This way you only have one loop, using the nested loops blows them out exponentially