Excelmacros按行排列单元格的长度

几年前，通过浏览不同的论坛，我创build了一个按长度，最长到最短（按单元格中的字符数）排列列的macros。 我粘贴特殊与转置到一张新的工作表，以获得列作为列。 然后，我把这个macros的VBS代码粘贴了100次，所以每次运行可以做100个列。

今天我试着运行这个macros，但它现在不工作了:(

这是我使用的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 

应该有一个更好的解决scheme来sorting行，而不需要将行转换为列，也不会粘贴相同的VBS代码100次。

任何人都可以帮助我的macros，可以简单地sorting单元格中的字符的长度在每个单元格与无限的行和列？ 最长的细胞应该是第一个，最短的 – 最后一个

在我的情况下，我有745行和列范围从A到BA。

提前致谢

根据要求更新一个灵感：

Answer 1

这很慢。 785行需要几秒钟，我不知道为什么。 它虽然工作。 它将每一行复制到一个新工作表中，向该工作表添加一个LEN公式并对公式进行sorting。 然后将行复制回原始图纸：

 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

道格这是一个非常聪明的例行公事。 为了我自己的娱乐，我试着加快了速度。 使用数组传输数据，而不是直接从范围复制到范围似乎这样做。 能够缩短从35秒到2秒以内的sorting时间（800行×20列）。 所以如果任何人有兴趣，这是你的例程，与我的修改。

 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