按行sorting数据

我有一个包含许多数字的电子表格，我希望将具有相同数字的单元格移动到同一行。 目前，我的电子表格看起来像这样：

* May Jun Jul Aug Sep Oct * 10584 10589 10584 10584 10589 10589 * 10589 11202 10589 10589 11202 11202 * 11202 9799 11202 11202 11677 11677 * 11677 

我想有一些VBA代码来组织数据，使具有相同值的单元格在同一行，所以它应该看起来像这样：

 * May Jun Jul Aug Sep Oct * 9799 * 10584 10584 10584 * 10589 10589 10589 10589 10589 10589 * 11202 11202 11202 11202 11202 11202 * 11677 11677 11677 

空单元格在没有数字的地方。 我试图通过论坛search，但我无法find任何类似的东西。 我真的会对此有所帮助。 谢谢你的时间。

Answer 1

这是一个在任意大小的数据块上工作的方法。 它通过对列进行sorting，然后如果它们不等于行中的最小值，则向下移动单元格。

这里唯一可以调整的实际参数是起始单元格： rng_start ，最初设置为ActiveCell 。 这段代码也使用CurrentRegion所以数据需要是一个块…或者你可以重新定义这几行。

码

 Sub SortAndPutSameValuesInSameRow() 'get data ranges Dim rng_start As Range Set rng_start = ActiveCell Dim rng_data As Range Set rng_data = rng_start.CurrentRegion Set rng_data = Intersect(rng_data, rng_data.Offset(1)) 'sort by column Dim rng_col As Range For Each rng_col In rng_data.Columns rng_col.Sort Key1:=rng_col Next 'iterate through rows and arrange Dim rng_row As Range For Each rng_row In rng_data.Rows Dim rng_cell As Range For Each rng_cell In rng_row.Cells If rng_cell.Value <> Application.WorksheetFunction.min(rng_row) Then rng_cell.Insert xlShiftDown End If Next 'break out if cell goes past data If Intersect(rng_row, rng_start.CurrentRegion) Is Nothing Then Exit For End If Next End Sub 

怎么运行的

这里的主要想法是，一旦列被sorting，您只需要将值向下移动，以便每行只保留最小的值。 这个逻辑也确保了所有相同的值在同一行。 请注意，如果有重复的值，您将得到一行匹配值，然后重复值（如果在多列中重复，也会匹配）。 具体评论：

• 代码的上半部分是为下面的迭代部分设置的。 它抓取数据块并构build排除标题的范围。
• 对于数据块，它首先遍历每一列并依次对它们进行sorting。
• 一旦sorting，它将遍历数据的每一行，并检查当前值是否等于行中的最小值。
• 如果是这样，那么这个单元格可以保持放置。 如果不是，则需要将这些值向下移动以形成空白单元格。
• 最后，还有一个检查是在需要时退出循环。 这在For Each循环中有点奇怪，但是这是必须的，因为范围的大小随着迭代而变化（因为Insert ）。

由于我使用的是Rows和Columns ，所以这个代码将适用于工作表上任何地方的数据，以及任意数量的列。

显示结果与您的数据之前/之后的图片

之前

后

Answer 2

这应该工作：

 Sub t() Dim i As Integer, min As Long, rowCurrent As Integer Dim j As String For i = 1 To 6 'sort all the columns first Columns(i).Sort key1:=Cells(2, i), _ order1:=xlAscending, Header:=xlYes Next i rowCurrent = 2 While Not Application.WorksheetFunction.Sum(Range("A" & rowCurrent & ":F" & rowCurrent)) = 0 min = Application.WorksheetFunction.min(Rows(rowCurrent)) For i = 1 To 6 If Cells(rowCurrent, i) <> min Then Range(Cells(rowCurrent, i).Offset(1, 0).Address & ":" & Cells(Rows.Count, i).End(xlUp).Offset(1, 0).Address).Value = _ Range(Cells(rowCurrent, i).Address & ":" & Cells(Rows.Count, i).End(xlUp).Address).Value Cells(rowCurrent, i).Value = "" End If Next i rowCurrent = rowCurrent + 1 Wend End Sub 

Answer 3

这里有另外一种方法，如果你有大量的数据，运行速度会更快，因为它只能从工作表中读写数据 – 所有的“工作”都是在VBA中完成的。

你可能会想把结果移到不同的工作表上 – 你需要做的就是改变你设置的wsRes和可能的rRes

• 创build一个用户定义的对象，其中包含“数字”和该数字出现的列的集合。

• 将源数据读入一个数组

• 遍历数组，创build一组唯一的数字以及所有出现这些数字的列。
• 按编号sorting对象。
• 将结果写入数组
• 将数组写入工作表

您必须重命名类模块 cNumCols

类模块

 Option Explicit Private pNum As Long Private pCOL As Long Private pCOLs As Collection Private Sub Class_Initialize() Set pCOLs = New Collection End Sub Public Property Get Num() As Long Num = pNum End Property Public Property Let Num(Value As Long) pNum = Value End Property Public Property Get COL() As Long COL = pCOL End Property Public Property Let COL(Value As Long) pCOL = Value End Property Public Property Get COLs() As Collection Set COLs = pCOLs End Property Public Sub ADD(COLval As Long) pCOLs.ADD COLval End Sub 

常规模块

 Option Explicit Sub SortNumbers() Dim cNC As cNumCols, colNC As Collection Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range Dim vSrc As Variant, vRes() As Variant Dim i As Long, J As Long 'Set source and destination sheets and ranges Set wsSrc = Worksheets("sheet4") Set wsRes = Worksheets("sheet4") Set rRes = wsRes.Range("L1") With wsSrc vSrc = .Range("a1").CurrentRegion End With 'collect list of unique numbers, along with their columns Set colNC = New Collection On Error Resume Next For i = 2 To UBound(vSrc, 1) For J = 1 To UBound(vSrc, 2) If vSrc(i, J) <> "" Then Set cNC = New cNumCols With cNC .Num = vSrc(i, J) .COL = J .ADD .COL colNC.ADD cNC, CStr(.Num) If Err.Number = 457 Then Err.Clear colNC(CStr(.Num)).ADD .COL End If If Err.Number <> 0 Then 'stop to debug error Debug.Print Err.Source, Err.Number, Err.Description Stop End If End With End If Next J Next i On Error GoTo 0 'Sort collection by number CollectionBubbleSort colNC, "Num" 'Populate results array ReDim vRes(0 To colNC.Count, 1 To UBound(vSrc, 2)) 'header row For J = 1 To UBound(vSrc, 2) vRes(0, J) = vSrc(1, J) Next J 'data For i = 1 To colNC.Count With colNC(i) For J = 1 To .COLs.Count vRes(i, .COLs(J)) = .Num Next J End With Next i 'Clear results area and write results Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes With .Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter End With .EntireColumn.AutoFit End With End Sub 'Could use faster sort routine if necessary Sub CollectionBubbleSort(TempCol As Collection, Optional Prop As String = "") Dim i As Long Dim NoExchanges As Boolean ' Loop until no more "exchanges" are made. Do NoExchanges = True ' Loop through each element in the array. For i = 1 To TempCol.Count - 1 If Prop = "" Then ' If the element is greater than the element ' following it, exchange the two elements. If TempCol(i) > TempCol(i + 1) Then NoExchanges = False TempCol.ADD TempCol(i), after:=i + 1 TempCol.Remove i End If Else If CallByName(TempCol(i), Prop, VbGet) > CallByName(TempCol(i + 1), Prop, VbGet) Then NoExchanges = False TempCol.ADD TempCol(i), after:=i + 1 TempCol.Remove i End If End If Next i Loop While Not (NoExchanges) End Sub