Equalizer vba through range in alphabetical order

Question

I want to iterate over a range of cells in alphabetical order to create a report in alphabetical order. I do not want to sort the sheet, since 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 

Please note that this code has not been tested, it is sorted by the first two letters only and takes a lot of time, since it has to scroll through the text 676 times. Is there a better way than this?

Answer 1

Here is Dan Donoghue's idea in code. You can skip using the slow search function, fully preserving the original data order before sorting 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

Try to approach from a different angle.

Copy range to new book

Sort a copied range using Excels sort function

Copy the sorted range to an array

Close temp workbook without saving

Complete the array using the Find function to find the value in order and run the code.

Post back if you need help writing this, but it should be pretty simple. You will need to transfer the range to the array, and you will need to reduce the size of the array as an option.

This way you only have one loop, using nested loops exposes them exponentially

Answer 3

Perhaps create an extra column with numbers from 1 to the maximum value (to remember the order), then sort by column using Excel sort, do your thing, re-sort the newly created column first (for sorting) and delete its column

Answer 4

You can transfer your current report generation procedure to another sub and call it from the first when you are doing a loop 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 work with your existing data, listing the available report values ​​in ascending order in the VBE Immediate window.

An additional level of upward sorting can be easily added with another nested For / Next and concatenation of the new letter in the sFLTR variable to Chr(42) ..

Answer 5

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

The image of the ranges and results shows the data in the left field and the sorted “report” on the right. My report just copies the data from the original row. You could do everything at that moment. I added paint after the fact to show compliance.

The code goes through the data index, sorts the values, and then runs them again to output the data. It uses Find/FindNext to get the source element from a 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 /questions/85581/vba-array-sort-function/560026#560026 '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 

Code Notes:

• I took the quicksort code from this previous answer and added UCase to the UCase comparisons and the Optional parameters I entered (and Variant for this to work).
• The Find/FindNext scans the source data and finds the sorted elements in it. If a duplicate is found (that is, if the current value matches the previous value), then it uses FindNext , starting with the previously found record.
• The generation of my report simply takes values ​​from a data table. rng_search contains the Range current item in the source data source.
• I use Application.Tranpose to force .Value be a 1-D array instead of the usual multidimensional one. See this answer for this use . Move the array again if you want to output it to the column again.
• the Select Case bit is just a hacker way to conduct a short circuit assessment in VBA. See this previous answer about using this.