0

几年前，通过浏览不同的论坛，我为自己制作了一个宏，它按长度对列进行排序，从最长到最短（按单元格中的字符数）。我正在将特殊的转置粘贴到新工作表中，以将行列为列。然后我将 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 的列范围。

提前致谢

根据要求更新截图： 在此处输入图像描述

4

2 回答 2

3

这很慢。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-03T16:41:31.743 回答
1

这是一个非常聪明的例程道格。只是为了我自己的乐趣，我尝试了加快速度。使用数组来传输数据而不是直接从一个范围复制到另一个范围似乎可以做到这一点。能够将排序时间（800 行 x 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-04T17:56:43.110 回答