特定のテキストの後に行を挿入する - VBA

Question

特定のテキストが見つかった後にExcelをスプレッドシートに挿入したい。テキストはN回現れ、最後にテキストが表示された後に新しい行を挿入する必要があります。

私は、TextBとTextCが、私はマクロを実行するたびに、私は最後の時間TextA後に新しい行を挿入する必要が

ColumnA 
TextA 
TextA 
TextA 
TextA 
TextB 
TextB 
TextB 
TextB 
TextC 
TextC 
TextC 
TextC 

表示されているものの例。

特定のテキストが列に表示される最大回数を見つける方法はありますか？そうすれば、私が望むことをすることが可能になります。私はそれぞれのテキストが表示された回数をカウントし、変数にこの値を代入しようとした

：EDIT

その後

Sub count() 
Dim A As Integer 
A = Application.WorksheetFunction.CountIf(Range("B:B"), "TextA") 

Dim B As Integer 
B = Application.WorksheetFunction.CountIf(Range("B:B"), "TextB") 

Dim C As Integer 
C = Application.WorksheetFunction.CountIf(Range("B:B"), "TextC") 
End Sub 

私は新しい行を挿入しようとした

Sub insert_row() 
    Rows("4+A:4+A").Select 'The number 4 is the first row `TextA` appears. So 4+A where I need to insert my new row. 
    Selection.Insert Shift:=xlDown 
End Sub 

このコードでは、問題があります。

1 - Aには、TextA,TextBおよびTextCのテキストがあります。実際に私は30の異なるテキストを列に入れています。

2 - Sub insert_row（）が機能しません。

Answer 1

これは、セルがループして、セルがその下のセルと等しくなく、セルが空白でない場合に1つの行を追加します。

Sub Insert() 
    Dim LastRow As Long 
    Dim Cell As Range 

Application.ScreenUpdating = False 


    LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(-4162).Row 

    For Each Cell In Sheets("Sheet1").Range("A1:A" & LastRow) 
     If Cell.Value <> Cell.Offset(1, 0) Then 
      If Cell.Value <> "" Then 
       Sheets("Sheet1").Rows(Cell.Row + 1).Insert 
      End If 
     End If 
    Next Cell 

Application.ScreenUpdating = True 


End Sub 

Answer 2

パフォーマンスはあなたにとって価値があります。

次のコードでは、VBEのツール►参照に移動し、Microsoft Scripting Runtimeを追加する必要があります。これは、Scripting.Dictionaryのライブラリ定義を保持します。ただし、CreateObject（ "Scripting.Dictionary"）を使用する場合、ライブラリ参照は必要ありません。 あなたは、あなたは、その値が使用された最後の時間を見つけて、右下の行を挿入列A内の個別の値を見つけるために、スクリプト辞書を使用し、このコードで

。

Sub findlastItem() 

Dim unique As Object 
Dim firstcol As Variant 

Set unique = CreateObject("Scripting.Dictionary") 

With Worksheets("sheet1") 

firstcol = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Value2 

For v = LBound(firstcol, 1) To UBound(firstcol, 1) 
If Not unique.Exists(firstcol(v, 1)) Then _ 
       unique.Add Key:=firstcol(v, 1), Item:=vbNullString 
     Next v 
    End With 

    For Each myitem In unique 
    findAndInsertRow myitem 
    Next 

End Sub 


Sub findAndInsertRow(findwhat As Variant) 

    Dim FindString As String 
    Dim Rng As Range 
    Dim LastRange As Range 

    listOfValues = Array(findwhat) 

    If Trim(findwhat) <> "" Then 
     With Sheets("Sheet1").Range("A:A") 

       Set Rng = .Find(What:=listOfValues(i), _ 
           After:=.Cells(.Cells.Count), _ 
           LookIn:=xlValues, _ 
           LookAt:=xlWhole, _ 
           SearchOrder:=xlByRows, _ 
           SearchDirection:=xlPrevious, _ 
           MatchCase:=False) 
       If Not Rng Is Nothing Then 
        Rng.Offset(1, 0).Insert 
       End If 

     End With 
    End If