如何从不同列中的一列中分离相同的数字？答案

【问题标题】：How to separate same numbers from one column in different different columns?如何从不同列中的一列中分离相同的数字？
【发布时间】：2018-04-03 11:06:41
【问题描述】：

假设我有类似的数据

我希望将其分隔为

请帮我解决这个问题，我会非常感谢你。

【问题讨论】：

尝试文本到列。检查this tutorial
我不明白 - 你不想对你的数据做任何事情吗？
如果您附上截图将有助于我们了解。并请发布您迄今为止为实现这一目标所做的尝试。
好的，现在您已经编辑了您的问题。文本到列将不起作用。您将其标记为 VBA。贴出你试过的代码
其实我想根据有多少重复来区分这些数字

标签： vba excel excel-formula

【解决方案1】：

试试这个代码：

Sub SplitToColumns()
Dim numbers As Variant, lastRow As Long, i As Long, col As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
col = 1
'read all column A (I assumed you store these numbers there)
numbers = Range("A1:A" & lastRow).Value2
'clear column A, as we will write here
Range("A1:A" & lastRow).Clear

Cells(1, 1).Value = numbers(1, 1)
For i = 2 To lastRow
    'if the value is the same as previous one, we will write in next column
    If numbers(i, 1) = numbers(i - 1, 1) Then
        col = col + 1
    'if number is different from previous, then write in first column (A)
    Else
        col = 1
    End If
    Cells(i, col).Value = numbers(i, 1)
Next
End Sub

这会生成以下输出：

A    will become     A | B | C
1                    1 |   |
1                      | 1 |
1                      |   | 1
2                    2 |   |
2                      | 2 |
3                    3 |   |

【讨论】：

谢谢@Michał Turczyn，这段代码也很好用.. :)
我尝试了列表中的代码 1 1 1 1 2 2 2 1 4 5 6 6 代码有效，但输出的是 TO 想要的
@Storax 示例输入不包括这种情况。另外，在这种情况下，只需对列进行排序...
是的，你是对的，输入不包括这个并且可以预先排序。
@AkshayJadhav 如果答案解决了您的问题，那么您应该接受它并选择投票。

【解决方案2】：

如果您在 Sheet1 中有数据，例如：

选择数据并运行这个宏：

Sub DataSpreader()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i As Long, K As Long, j As Long
    Dim r As Range

    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    s2.Cells(1, 1) = s1.Cells(1, 1)
    K = 1

    For i = 2 To Intersect(Selection, s1.UsedRange).Count
            If s1.Cells(i, 1) = s1.Cells(i - 1, 1) Then
                s2.Cells(i, K + 1) = s1.Cells(i, 1)
                K = K + 1
            Else
                K = 1
                s2.Cells(i, 1) = s1.Cells(i, 1)
            End If
    Next i
End Sub

将在 Sheet2 上生成这个：

【讨论】：

非常感谢@Gary 的学生，它工作得太好了...：D

【解决方案3】：

通常，当您在 StackOverflow 中提出问题时，始终建议您提供一些代码（或您尝试过的代码）： https://stackoverflow.com/help/how-to-ask

不过，如果您认为输入应该来自一个单元格并返回到下一个单元格，这是另一种可能的解决方案：

Public Sub TestMe()

    Dim sourceRange As Range
    Dim resultArray As Variant

    Set sourceRange = Worksheets(1).Range("A1")
    resultArray = CharacterArray(sourceRange.Value2)

    Dim cnt         As Long
    Dim result      As String
    Dim spaces      As String


    For cnt = (LBound(resultArray) + 1) To UBound(resultArray)
        If resultArray(cnt) = resultArray(cnt - 1) Then
            spaces = spaces & " "
            result = result & spaces & resultArray(cnt) & vbCrLf
        Else
            spaces = vbNullString
            result = result & resultArray(cnt) & vbCrLf
        End If
    Next cnt

    sourceRange.Offset(0, 1) = result

    Debug.Print result

End Sub

还有字符数组：

Function CharacterArray(value As String) As Variant

        Dim cnt         As Long
        Dim result      As Variant
        Dim someVal     As String

        For cnt = 1 To Len(value)
            someVal = Mid(value, cnt, 1)
            If someVal Like WorksheetFunction.Rept("[^a-zA-Z0-9.]", 1) Then
                If IsEmpty(result) Then
                    ReDim result(1)
                Else
                    ReDim Preserve result(UBound(result) + 1)
                End If
                result(UBound(result)) = Mid(value, cnt, 1)
            End If
        Next cnt

        CharacterArray = result

End Function

实际上，此解决方案最大的“问题”是您必须找到一种方法将A1 范围内的值拆分为一个数组。这是通过以下 3 行完成的，它们从新数组中删除新行：

For cnt = 1 To Len(value)
    someVal = Mid(value, cnt, 1)
    If someVal Like WorksheetFunction.Rept("[^a-zA-Z0-9.]", 1) Then

一旦你有了一个包含你需要的值的漂亮数组，你只需要像这样比较循环中的当前值和前一个值：

If resultArray(cnt) = resultArray(cnt - 1) Then

如果它们相同，则将spaces 增加 1：

spaces = spaces & " "

【讨论】：