Question

我不确定标题是否正确。如果你有更好的主意，请纠正我。

这是我的问题：请看图片。

这个excel表只包含一列，让我们说ColumnA。在ColumnA中，有一些细胞在连续细胞中重复两次或三次（甚至更多次）。

我希望根据那些重复的细胞转换excel表。对于那些重复三次或更多次的物品，只保留其中两种。

[如右图所示。原来有三个B，目标只是保留两个B并删除其余的Bs。]

对我来说，这是一项非常艰巨的任务。为了更容易，转换后不需要删除空行。

任何形式的帮助都将受到高度赞赏。谢谢！

＃

更新

请看图片。如果再次显示，请不要删除这些项目...

Answer 1

已编辑 - 请参见下文尝试此操作。假设数据在＆＃34; Sheet1＆＃34;中，并且有序数据被写入＆＃34;结果＆＃34;。我将重复的数据（A，B，C等）命名为sMarker，其间的值为sInsideTheMarker。如果标记不连续，则代码将失败。

Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String

'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
    If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
        j = j + 1
        If j = 1 Then
            k = k + 1
            a = 2
            sMarker = Worksheets("Sheet1").Cells(i, 1).Value
            Worksheets("Results").Cells(k, 1).Value = sMarker
        End If
    Else 'If not same values in consecutive cells
        sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
        Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
        a = a + 1
        j = 0
    End If
Next i
End Sub

EDITION：如果您想在同一张表格中显示结果（＆＃34; Sheet1＆＃34;），并保持结果的空行与您的问题完全一致，请尝试以下

Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String

'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
    If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
        j = j + 1
        If j = 1 Then
            k = i
            a = 5
            sMarker = Worksheets("Sheet1").Cells(i, 1).Value
            Worksheets("Sheet1").Cells(k, 4).Value = sMarker
        End If
    Else 'If not same values in consecutive cells
        sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
        Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
        a = a + 1
        j = 0
    End If
Next i
End Sub

Answer 2

如果您可以删除具有两个以上计数的值，那么我建议这可能有效：

Sub count_macro()

Dim a As Integer
Dim b As Integer

a = 1

While Cells(a, 1) <> ""

    b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))

    If b > 2 Then
        Cells(a, 1).Delete Shift:=xlUp
    End If

    b = 0
    a = a + 1

Wend

End Sub

Answer 3

这应该这样做。它从第2行开始直到它结束时在列A中输入，并忽略超过2个相同的连续值。然后将它们分别复制并粘贴它们。如果您的数据位于不同的列和行中，请相应更改sourceRange变量和i变量。

Sub SETranspose()

Application.ScreenUpdating = False

Dim sourceRange As range
Dim copyRange As range
Dim myCell As range



Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))

Dim startCell As range

Set startCell = sourceRange(1, 1)

Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True

For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1

If Cells(i, 1).Value = startCell.Value Then
    If haveTwo Then
        range(startCell, Cells(i, 1)).Copy
        startCell.Offset(0, 4).PasteSpecial Transpose:=True
        Application.CutCopyMode = False
        haveTwo = False
    End If
    End If
    'if the letter changes or end of set, then copy the set over
    'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
                'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
    If Len(Cells(i, 1).Value) > 1 Then
        Set copyRange = Cells(i, 1)
        copyRange.Copy
        Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
        Application.CutCopyMode = False
        'Set startCell = sourceRange(i - 1, 1)
    ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
        Set startCell = sourceRange(i - 1, 1)
        haveTwo = True
    End If

Next i

'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing

Application.ScreenUpdating = True

End Sub

Excel VBA：如何转换这种单元格？

3 个答案: