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

Question

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

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

這是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：

Answer 1

這是緩慢的。 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 

Answer 2

這是一個非常聰明的例行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