Question

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

*  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

在没有数字的地方使用空单元格。我尝试在论坛中搜索，但我找不到任何类似的东西。我真的会对此有任何帮助。谢谢你的时间。

Answer 1

这应该有效：

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 2

这是一种适用于任意大小的数据块的方法。它的工作原理是对列进行排序，然后如果单元格不等于行中的最小值，则将单元格向下移动。

此处要调整的唯一真实参数是起始单元格：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

工作原理

这里的主要思想是，一旦对列进行排序，您只需要向下移动值，以便每行中只保留最小值。此逻辑还确保所有相同的值都在同一行中。请注意，如果存在重复值，您将获得一行匹配值，然后重复值（如果在多列中重复，也会匹配）。具体意见：

代码的上半部分是为下面的迭代部分设置的。它会抓取数据块并构建一个排除标题的范围。
使用数据块，它首先遍历每一列并依次对它们进行排序。
排序后，它会遍历数据的每一行，并检查当前值是否等于行中的最小值。
如果是这样，那么那个细胞可以留下来。如果没有，则值需要向下移动以创建一个空白单元格。
最后，需要时检查是否会退出循环。这在For Each循环中有点奇怪但是是必需的，因为范围的大小在迭代时会发生变化（因为Insert）。

由于我使用的是Rows和Columns，因此此代码适用于工作表上任意位置的数据以及任意数量的列。

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

之前的

before

后的

enter image description here

Answer 3

这是另一种方法，如果你有大量的数据，应该运行得更快，因为它只读取和写入工作表一次 - 所有“工作”都在VBA内完成。

您可能希望将结果移到另一个工作表 - 您只需要更改设置wsRes和可能的rRes

创建一个用户定义的对象，该对象由“数字”和出现该数字的列集合组成。
将源数据读入数组
遍历数组，创建一个唯一数字的集合以及出现这些数字的所有列。
按编号对对象排序。
将结果写入数组
将数组写入工作表

您必须重命名课程模块 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

按行排序数据

3 个答案:

班级单元

常规模块