Question

几年前，通过浏览不同的论坛，我自己创建了一个宏，它按长度排序列，最长到最短（按单元格中的字符数）。我特意将transpose粘贴到新工作表中以将行列为列。然后我将宏中的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次......

任何人都可以帮我处理这个宏，它可以简单地按照每个单元格中字符长度排列行中的单元格，行数和列数不受限制吗？最长的细胞应该是第1，最短 - 最后

就我而言，我有745行，列范围从A到BA。

提前致谢

根据要求更新screnshot： enter image description here

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

这是一个非常聪明的常规道格。为了我自己的娱乐，我尝试了加速它。使用数组传输数据而不是直接从范围复制到范围似乎是这样做的。能够将排序时间（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

Excel宏按行长度排序单元格

2 个答案: