Vba Excel宏按长度对行中的单元格进行排序

几年前，通过浏览不同的论坛，我为自己制作了一个宏，可以按长度、从长到短（按单元格中的字符数）对列进行排序。我正在用转置粘贴到一个新的工作表，以便将行作为列列出。然后我将VBS代码粘贴到宏中100次，这样每次运行它就可以执行100列操作。

今天我试着运行这个宏，但现在根本不起作用：(

这是我使用的VBS代码（没有100个粘贴）：

应该有一个更好的解决方案，可以按行排序，而无需将行转换为列，也无需将相同的VBS代码粘贴100次

有人能帮我做一个宏吗？这个宏可以按照每个单元格中的字符长度对单元格进行行排序，每个单元格的行和列都不限。最长的单元格应该是第一个，最短的单元格应该是最后一个

在我的例子中，我有745行和列，范围从A到BA

提前谢谢

根据请求更新screnshot：

---

这很慢。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

---

这很慢。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

---

道格，这是一个非常聪明的例行程序。只是为了我自己的娱乐，我尝试了一些加速。使用数组来传输数据，而不是直接从一个范围复制到另一个范围，似乎可以做到这一点。能够减少排序时间（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

---

道格，这是一个非常聪明的例行程序。只是为了我自己的娱乐，我尝试了一些加速。使用数组来传输数据，而不是直接从一个范围复制到另一个范围，似乎可以做到这一点。能够减少排序时间（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

---

你说你从一张纸上取数据，然后粘贴到另一张纸上？你没有特别引用任何一张纸，所以你有可能从错误的地方取数据吗？不太可能是我用错了纸，因为一个文件中只有一张纸。但不管怎么说，我使用的方法非常难看，我只是讨厌使用它，所以不管怎么说，它可能是错误的对于VBS来说，这是一个很好的时机，这样做很容易而且正确。在排序过程之后，你能发布一个源数据子集的屏幕打印和另一个具有所需格式的屏幕打印吗？你想让每个列从小到大排序，而不考虑相邻列吗？@Douglancy-我想让它们从大到小，列不重要。你说你接受data从一张纸粘贴到另一张纸上？你没有特别引用任何一张纸，所以你有可能从错误的地方获取数据吗？不太可能我使用了错误的纸，因为一个文件中只有一张纸。但无论如何，我使用的方法非常难看，我只是讨厌使用它，所以无论如何，这可能是VBS的好时机这很简单，正确。排序过程结束后，你能发布一个源数据子集的屏幕打印图和另一个符合你要求格式的屏幕打印图吗？你想让每一列从小到大排序，而不考虑相邻的列吗？@Douglancy-我想让它们从大到小，列并不重要！这正是我需要的，而且它这样做的时间比我用其他方法做的时候快得多。你可能也应该将

应用程序。计算
设置为手动，这应该会提高速度…@Sam，我做了。它没有，至少在非常有限的测试中是这样。非常感谢！这正是我需要的，而且它做的时间比我做的时候快得多这是另外一种方法。您可能也应该将
应用程序.Calculation
设置为手动，这应该会提高速度…@Sam，我做了。它没有，至少在非常有限的测试中没有。