Excel宏按長度對行中的單元格進行排序

幾年前，通過瀏覽不同的論壇，我創建了一個按長度，最長到最短（按單元格中字符數）排序列的宏。我正在將一個特殊的轉置粘貼到一張新的表格中，以將行列爲列。然後，我將這個VBS代碼粘貼到宏中100次，這樣它可以在每次運行時執行100個列。
Excel宏按長度對行中的單元格進行排序

今天我試圖運行這個宏，但它並沒有在所有現在的工作:(

這是VBS代碼我使用（不含100種膏）：

Sub SortByLength2() 
Dim lLoop As Long 
Dim lLoop2 As Long 
Dim str1 As String 
Dim str2 As String 
Dim MyArray 
Dim lLastRow As Long 

lLastRow = Range("A65536").End(xlUp).Row 
MyArray = Range(Cells(2, 1), Cells(lLastRow, 1)) 
'Sort array 
For lLoop = 1 To UBound(MyArray) 
    For lLoop2 = lLoop To UBound(MyArray) 
     If Len(MyArray(lLoop2, 1)) > Len(MyArray(lLoop, 1)) Then 
      str1 = MyArray(lLoop, 1) 
      str2 = MyArray(lLoop2, 1) 
      MyArray(lLoop, 1) = str2 
      MyArray(lLoop2, 1) = str1 
     End If 
    Next lLoop2 
Next lLoop 
'Output sorted array 
Range("JO1:JO" & UBound(MyArray) + 1) = (MyArray) 
    Range("A:A").Delete Shift:=xlToLeft 
End Sub

應該有一個更好的解決方案排序在行中，不需要將行轉換爲列，也不需要粘貼相同的VBS代碼100次...

任何人都可以幫助我，可以簡單地按行中的字符長度排序單元格無限的行和列？最長的單元應該是第一個，最短的 - 最後

在我的情況下，我有745行和列範圍從A到BA。

預先感謝

更新，按照請求，screnshot： enter image description here

來源

2013-11-03 CamSpy

你說你從1張表中取數據並粘貼到另一張？您沒有專門參考任何表格，因此您是否可能從錯誤的地方獲取數據？ – Sam

我不太可能使用錯誤的工作表，因爲文件中只有一個工作表。但無論如何，我使用的方法是超級醜陋的，我只是討厭使用它，所以無論如何，它可能是一個VBS的好時機，它會很容易和正確 – CamSpy

你可以發佈你的源數據的子集和另一個屏幕打印在排序過程後使用您所需的格式？ – Sam

這是緩慢的。 785行需要幾秒鐘，我不知道爲什麼。它雖然工作。它將每一行復制到一個新工作表中，向該工作表中添加LEN公式並對公式進行排序。然後它將行復制回原始工作表：

Sub SortAllCols() 
Dim wsToSort As Excel.Worksheet 
Dim wbTemp As Excel.Workbook 
Dim wsTemp As Excel.Worksheet 
Dim row As Excel.Range 
Dim Lastrow As Long 

    Set wsToSort = ActiveSheet 'Change to suit 
    Set wbTemp = Workbooks.Add 
    Set wsTemp = wbTemp.Worksheets(1) 
    Application.ScreenUpdating = False 

    With wsToSort 
     Lastrow = .Range("A" & .Rows.Count).End(xlUp).row 
     For Each row In .Range("A1:A" & Lastrow) 
      wsTemp.UsedRange.EntireRow.Delete 
      row.EntireRow.Copy Destination:=wsTemp.Range("A1") 
      wsTemp.UsedRange.Offset(1, 0).FormulaR1C1 = "=LEN(R[-1]C)" 
      wsTemp.UsedRange.EntireRow.Sort Key1:=wsTemp.UsedRange.Rows(2), order1:=xlDescending, Orientation:=xlSortRows 
      wsTemp.Rows(1).Copy Destination:=row 
     Next row 
    End With 
    Application.ScreenUpdating = True 
    wbTemp.Close False 
    End Sub

來源

2013-11-03 16:41:31

非常感謝！這正是我所需要的，而且它所做的時間比我在其他方面做得更快。 – CamSpy

你也許應該設置'Application.Calculation'以手動，以提高速度... – Sam

@Sam，我做到了。它沒有，至少在非常有限的測試中。 –

這是一個非常聰明的例行Doug。爲了我自己的娛樂，我嘗試了一些速度。使用數組來傳輸數據，而不是直接從範圍複製到範圍似乎這樣做。能夠將排序時間（800行×20列）從35秒縮短到2秒以內。所以如果任何人有興趣，這是你的例程，與我的修改。

Sub SortAllCols() 
    Dim wsToSort As Excel.Worksheet 
    Dim wbTemp As Excel.Workbook 
    Dim wsTemp As Excel.Worksheet 
    Dim rRow As Excel.Range 
    Dim Lastrow As Long 
    Dim rT As Range, v 

    Set wsToSort = ActiveSheet 'Change to suit 
    Set wbTemp = Workbooks.Add 
    Set wsTemp = wbTemp.Worksheets(1) 
    Application.ScreenUpdating = False 

    With wsToSort 
     Lastrow = .Range("A" & .Rows.Count).End(xlUp).row 
     For Each rRow In .Range("A1:A" & Lastrow) 
      wsTemp.UsedRange.Clear 
      v = .Range(rRow, .Cells(rRow.row, .Columns.Count).End(xlToLeft)).Value 
      If IsArray(v) Then 'ignore single cell range 
       Set rT = wsTemp.Range("A1").Resize(, UBound(v, 2)) 
       rT.Value = v 
       rT.Offset(1, 0).FormulaR1C1 = "=LEN(R[-1]C)" 
       rT.Resize(2).Sort Key1:=rT.Rows(2), order1:=xlDescending, Orientation:=xlSortRows 
       v = rT.Rows(1).Value 
       rRow.Resize(, UBound(v, 2)).Value = v 
      End If 
     Next rRow 
    End With 
    Application.ScreenUpdating = True 
    wbTemp.Close False 
End Sub

來源

2013-11-04 17:56:43 DaveU

Excel宏按長度對行中的單元格進行排序

回答

相關問題