セルの値に基づいてセルを上に挿入

Question

このスクリプトを見つけて、自分のニーズに合わせていくつか修正しました。しかし、私は列Aにスペースを挿入し、任意の行で列Bと一致しない場合、その後の比較は、上記の1行を追加し続ける、だからではなく、行全体の

Sub BlankLine() 
    Dim Col As Variant 
    Dim Col2 As Variant 
    Dim BlankRows As Long 
    Dim LastRow As Long 
    Dim R As Long 
    Dim StartRow As Long 

    Col = "A" 
    Col2 = "B" 
    StartRow = 2 
    BlankRows = 1 

    LastRow = Cells(Rows.Count, Col).End(xlUp).Row 

    Application.ScreenUpdating = False 

    With ActiveSheet 
    For R = LastRow To StartRow + 1 Step -1 
     If .Cells(R, Col) <> .Cells(R, Col2) Then 
     .Cells(R, Col2).EntireRow.Insert Shift:=xlUp 
     End If 
    Next R 
    End With Application.ScreenUpdating = True 
End Sub 

を一つのセルを挿入する方法を見つけ出すことはできません偽の値。

Example: 1 1 
     2 3 
     3 4 

Becomes: 1 1 
     2 
     3 3 
      4 

ご協力いただければ幸いです！

Answer 1

.Cells(R, Col2).Insert Shift:=xlDown 

Answer 2

あなたはからあなたのループを変更する必要があります： - ：

Example: 1 3 
     2 1 
     3 2 

For R = StartRow To LastRow 
    If .Cells(R, Col).Value <> .Cells(R, Col2).Value Then 
     .Cells(R, Col2).Insert Shift:=xlDown 
    End If 
Next R 

警告の言葉に

For R = LastRow To StartRow + 1 Step -1 
    If .Cells(R, Col) <> .Cells(R, Col2) Then 
     .Cells(R, Col2).EntireRow.Insert Shift:=xlUp 
    End If 
Next R 

あなたのデータはこのように見える場合次のようになります。

Becomes: 1 
     2 
     3 3 
      1 
      2 

これを使用する前に、データが適切な順序であることを確認してください。