2015-06-02 37 views
5

Tôi muốn lặp qua một dải ô theo thứ tự bảng chữ cái để tạo báo cáo theo thứ tự bảng chữ cái. Tôi không muốn sắp xếp các tờ như thứ tự ban đầu là quan trọng.Excel vba lặp qua phạm vi theo thứ tự abc

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 

Lưu ý rằng mã này chưa được kiểm tra, chỉ sắp xếp theo 2 chữ cái đầu tiên và tốn thời gian vì nó phải lặp qua văn bản 676 lần. Có cách nào tốt hơn thế này không?

+0

Cảm ơn bạn đã trả lời tất cả mọi người, nhiều phương pháp khác nhau tại đây. Tôi chỉ đang cố chọn cái nào để sử dụng. – user2967539

+0

Bất cứ ai có bất kỳ ý tưởng tại sao N và Z trở lại chữ hoa trong mã trên? VBA có hoạt động không? – user2967539

+0

Bạn có thể đã khai báo (cùng một lúc) một biến hoặc thủ tục có tên là "N" và "Z" và đó là lý do tại sao trình chỉnh sửa đã thay đổi chúng thành chữ hoa. FWIW, mảng của bạn không hoạt động ở tất cả những gì bạn nghĩ khi bạn đã điền nó với các biến a, b, c, v.v. thay vì các ký tự "a", "b", "c". Có vẻ như không nghi ngờ gì rằng bạn không sử dụng Option Explicit và do đó trình biên dịch cho phép bạn tạo ra các lỗi cơ bản như sử dụng các biến không khai báo. ** Sử dụng Option Explicit! ** [Xem bài SO này.] (Http://stackoverflow.com/questions/2454552/whats-an-option-strict-and-explicit) –

Trả lời

1

Thử tiếp cận từ một góc khác.

Sao chép phạm vi sang một workbook mới

Sắp xếp phạm vi sao chép sử dụng vượt trội loại chức năng

Sao chép dãy được sắp xếp để một mảng

Đóng bảng tính tạm thời mà không lưu

Vòng sự mảng bằng cách sử dụng hàm Tìm kiếm để định vị giá trị theo thứ tự và chạy mã của bạn.

Đăng lại nếu bạn cần trợ giúp bằng văn bản nhưng điều này khá đơn giản. Bạn sẽ cần phải chuyển đổi phạm vi sang mảng và bạn sẽ cần phải làm mờ mảng của mình dưới dạng biến thể.

Bằng cách này bạn chỉ có một vòng lặp, sử dụng các vòng lồng nhau thổi chúng ra theo cấp số nhân

+0

Bất kỳ lý do nào tại sao một sổ làm việc riêng biệt, không phải là một riêng biệt tờ Dan? – user2967539

+0

Không thực sự, tôi thích tạo ra những cuốn sách tạm thời để chúng có thể dễ dàng bị thổi bay, nếu bạn thêm một cuốn sách vào một tờ, nó sẽ tạo ra nó khi bạn xóa nó. Tôi không chắc liệu Excel có xóa không gian, nó có thể kết thúc bloating workbook của bạn một chút (Điều này hoàn toàn dựa trên những gì "có thể" xảy ra, tôi không biết chắc chắn). –

+1

Ngoài ra, bằng cách tạo một sổ làm việc mới, bạn sẽ tránh được các vấn đề nếu sổ làm việc hiện tại được bảo vệ hoặc chia sẻ. –

0

Có lẽ tạo cột thêm với những con số từ 1 đến tối đa mà bạn cần (phải nhớ thứ tự), sau đó sắp xếp theo cột của bạn với loại của Excel , hãy sắp xếp lại theo cột được tạo thứ nhất (để sắp xếp lại) và xóa cột đó

+0

Đây là một ý tưởng tốt cho nó đơn giản, nó sẽ mess với định dạng có điều kiện mặc dù? – user2967539

+0

Nếu định dạng có điều kiện là hằng số cho tất cả các ô trong phạm vi hoặc nó sử dụng ô khác làm đường viền của điều kiện - có, nó sẽ vẫn còn nếu bạn bao gồm các ô đó trong phạm vi sắp xếp 'ActiveWorkbook.Worksheets (" Sheet1 "). Sort.SortFields.Add Khóa: = Phạm vi ("D1"), Sắp xếp: = xlSortOnValues, Thứ tự: = xlSự tăng dần, DataOption: = xlSortNormalWith ActiveWorkbook.Worksheets ("Sheet1"). Sắp xếp .SetRange Range ("C1: D43") .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin . Áp dụng Kết thúc với 'Phạm vi C1: D43 - phải nằm trong phạm vi với tất cả các ô bạn cần, bao gồm ô định dạng có điều kiện – Alexander

0

Bạn có thể di chuyển thường trình tạo báo cáo thực tế của mình sang một phụ khác và gọi nó từ đầu tiên khi bạn đi qua một chuỗi các kết quả được sắp xếp.

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 

Mã này nên chạy trên dữ liệu hiện tại của bạn, danh sách các giá trị báo cáo có sẵn trong một thứ tự tăng dần đến cửa sổ trước mắt của VBE.

Một cấp thêm ascending loại một cách dễ dàng có thể được thêm vào với một lồng nhau Ví/Next và một concatenating bức thư mới đến sFLTR biến trước Chr(42) ..

0

Một lựa chọn là để tạo ra một mảng các giá trị , nhanh chóng sắp xếp mảng, và sau đó lặp lại mảng đã sắp xếp để tạo báo cáo. Điều này hoạt động ngay cả khi có bản sao trong dữ liệu nguồn (đã chỉnh sửa).

Ảnh phạm vi và kết quả hiển thị dữ liệu trong hộp bên trái và "báo cáo" được sắp xếp ở bên phải. Báo cáo của tôi chỉ sao chép dữ liệu từ hàng gốc. Bạn có thể làm bất cứ điều gì vào thời điểm này. Tôi thêm màu sau khi thực tế để hiển thị các thư từ.

results of sorting

chạy qua chỉ số dữ liệu, sắp xếp các giá trị, và sau đó chạy qua chúng một lần nữa để xuất dữ liệu. Nó đang sử dụng Find/FindNext để lấy mục gốc từ mảng được sắp xếp.

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 

Ghi chú về mã:

  • tôi đã đưa ra những Sắp xếp đang nhanh từ previous answer này và thêm UCase để so sánh cho case-insensitive tìm kiếm và thực hiện các thông số Optional (và Variant cho rằng làm việc).
  • Phần Find/FindNext đang xem xét dữ liệu gốc và định vị các mục được sắp xếp trong đó. Nếu tìm thấy một bản sao (nghĩa là, nếu giá trị hiện tại khớp với giá trị trước đó) thì nó sử dụng FindNext bắt đầu từ mục nhập đã tìm thấy trước đó.
  • Tạo báo cáo của tôi chỉ lấy các giá trị từ bảng dữ liệu. rng_search giữ Range mục hiện tại trong nguồn dữ liệu gốc.
  • Tôi đang sử dụng Application.Tranpose để buộc .Value trở thành một mảng 1-D thay vì độ mờ tối đa như bình thường. Xem this answer for that usage. Transpose mảng một lần nữa nếu bạn muốn đầu ra vào một cột một lần nữa.
  • Các bit Select Case chỉ là một cách hacky để thực hiện đánh giá ngắn mạch trong VBA. Xem this previous answer về cách sử dụng.
+0

Tôi thích cái này, nhưng tôi cần sử dụng các cột xung quanh một phần của báo cáo. Điều đó có thể không? – user2967539

+0

Mọi thứ đều có thể :).Nếu bạn có thể xây dựng báo cáo của mình khỏi tham chiếu đến ô chỉ mục, thì chắc chắn. Không biết báo cáo của bạn bao gồm những gì, nhưng bạn có thể sử dụng 'Offset' để di chuyển xung quanh từ hàng đã cho và tính toán/tóm tắt bất cứ điều gì bạn muốn. Và nếu bạn kiểm tra ví dụ của tôi, tôi cũng đang sử dụng các cột xung quanh; Tôi chỉ xảy ra để sao chép giá trị thẳng. Bạn có thể làm toán ở đó hoặc bất cứ điều gì là cần thiết. –

2

Đây là ý tưởng của Dan Donoghue về mã. Bạn có thể bỏ qua bằng cách sử dụng chức năng Tìm chậm hoàn toàn bằng cách lưu trữ thứ tự gốc của dữ liệu trước khi bạn sắp xếp nó.

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 
+0

Được viết đẹp Rachel :). –

Các vấn đề liên quan