Excel VBA: Как преобразовать такие ячейки?

Question

Я не уверен, правильно ли указано. Пожалуйста, поправьте меня, если у вас есть идея.

Это моя проблема: Пожалуйста, смотрите изображение.

Этот лист Excel содержит только один столбец, скажем, ColumnA. В ColumnA есть несколько клеток, которые повторяют themselvs в продолжающихся клетках два или три раза (или даже больше).

Я хочу, чтобы лист Excel был преобразован в соответствии с этими повторяющимися ячейками. Для тех предметов, которые повторяются три или более раз, сохраняйте только два из них.

[Показано в правой части изображения. Есть три Bs изначально, цель - просто сохранить два Bs и удалить остальные Bs.]

Это очень сложная задача для меня. Чтобы упростить задачу, нет необходимости удалять пустые строки после преобразования.

Любая помощь будет высоко оценена. Благодаря!

#

Обновление:

Пожалуйста, смотрите картинку. Пожалуйста, не удалять элементы, если они показывают снова ...

Answer 1

EDITED - СМ НИЖЕ Попробуйте это. Предполагается, что данные находятся в «Sheet1», а упорядоченные данные записываются в «Результаты». Я назвал ваши повторяющиеся данные (A, B, C и т. Д.) Как sMarker и значения между ними как sInsideTMarker. Если маркеры не последовательны, код не будет выполнен.

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: Если вы хотите получить результаты в том же листе («Лист1»), и держать пустые строки, для результатов, чтобы выглядеть точно так, как ваш вопрос, попробуйте следующее

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

Это должно сделать это , Он принимает входные данные в столбце 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