Ordine alfabetico del ciclo vba di Excel nell'intervallo

Question

Desidero eseguire il ciclo di un intervallo di celle in ordine alfabetico per creare un rapporto in ordine alfabetico. Non desidero ordinare il foglio poiché l'ordine originale è importante.

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 

Si noti che questo codice non è testato, solo i tipi di le prime 2 lettere e richiede molto tempo come deve scorrere il testo 676 volte. C'è un modo migliore di questo?

Answer 1

Prova ad avvicinarti da una diversa angolazione.

Copia il campo per una nuova cartella di lavoro

ordinare l'intervallo copiato usando funzione di ordinamento Eccelle

Copia il campo ordinato ad un array

Chiudere la cartella di lavoro temporaneo senza salvare

Loop il array usando la funzione Trova per localizzare il valore in ordine ed eseguire il codice.

Postback se hai bisogno di aiuto per scrivere questo, ma dovrebbe essere abbastanza semplice. Sarà necessario trasporre l'intervallo sull'array e sarà necessario attenuare l'array come variante.

In questo modo si ha un solo ciclo, utilizzando i cicli annidati li spegne in modo esponenziale

Answer 2

Forse creare colonna in più con i numeri da 1 a massimo è necessario (da ricordare ordine), quindi ordinare per la colonna con il tipo di Excel , fai le tue cose, riordina la colonna creata per prima (per tornare indietro) ed elimina quella colonna

Answer 3

Puoi spostare la tua routine di generazione dei report su un altro sub e chiamarla dal primo mentre passi in rassegna una serie di partite ordinate.

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 

Questo codice dovrebbe funzionare su dati esistenti, che elenca i valori del report disponibili in ordine crescente per la finestra Immediata del VBE.

Un ulteriore livello di ordinamento crescente potrebbe facilmente essere aggiunto con un altro nidificato Per/Avanti e un concatenando la nuova lettera al variabile sFLTR prima Chr(42) ..

Answer 4

Una possibilità è quella di creare un array di valori , ordinare rapidamente l'array e quindi iterare l'array ordinato per creare il report. Funziona anche se ci sono duplicati nei dati di origine (modificato).

Immagine di intervalli e risultati mostra i dati nella casella di sinistra e il "report" ordinato sulla destra. Il mio rapporto copia semplicemente i dati dalla riga originale. Potresti fare qualsiasi cosa a questo punto. Ho aggiunto la colorazione dopo il fatto per mostrare la corrispondenza.

Codice attraversa l'indice dei dati, ordina i valori, e poi corre attraverso di loro ancora una volta per l'output dei dati. Sta usando Find/FindNext per ottenere l'oggetto originale dall'array ordinato.

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 

Note sul codice:

• ho preso il codice quick sort da questo previous answer e ha aggiunto UCase per i confronti per la ricerca tra maiuscole e minuscole e reso parametri Optional (e Variant per questo lavorare).
• La parte Find/FindNext sta passando attraverso i dati originali e individuando gli elementi ordinati al loro interno. Se viene trovato un duplicato (ovvero, se il valore corrente corrisponde al valore precedente), utilizza FindNext a partire dalla voce precedentemente trovata.
• La generazione del mio rapporto sta semplicemente prendendo i valori dalla tabella dei dati. rng_search contiene lo Range dell'elemento corrente nell'origine dati originale.
• Sto usando Application.Tranpose per forzare .Value in modo che sia una matrice 1-D invece che multipla come normale. Vedi this answer for that usage. Trasponi di nuovo l'array se vuoi eseguire nuovamente l'output in una colonna.
• Il bit Select Case è solo un modo hacky per eseguire la valutazione di cortocircuito in VBA. Vedi this previous answer sull'uso di quello.

Answer 5

Ecco l'idea di Dan Donoghue in codice. È possibile saltare completamente la funzione di ricerca lenta memorizzando l'ordine originale dei dati prima di ordinarlo.

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