Excel VBA 行数調整について こんにちは 行数調整について質問させてください sheet1の

Excel VBA 行数調整について
こんにちは　行数調整について質問させてください

sheet1の　B2にAと入力されており
sheet2B列を検索を行う

検索にて一致したら一致した箇所よりAをカウントし連続でAが3回続かなければ
行を挿入し行を調整する

下記はイメージです
マクロ実行前

sheet2
B列
1 A
2 A
3 B
4 C
5 C

実行後

B列
1 A
2 A
3空白←自動挿入
4 B
5 C
6 C

シートリンクの関係でどうしても行数調整をしなければならず手動では非常に手間なためどうかよろしくお願いします

質問者からの補足コメント

• 

  ご返答ありがとうございます
  質問なのですが教えていただいたプロググラムA列検索でしたので検索列をAに変更しプログラムをコピーして動かしたのですが無反応でした
  ただコピーするだけではいけなかったのでしょうか？

    補足日時：2017/10/20 11:09

No.2 回答者： t_fumiaki 回答日時： 2017/10/20 11:15

B列検索にするには以下です

Sub WK()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

END2 = Sh2.Range("B65536").End(xlUp).Row '最終行取得
個数 = 0

For Cnt2 = 1 To END2

If Sh2.Range("B" & Cnt2).Value <> Sh1.Range("B2").Value Then
If 個数 <> 2 Then
個数 = 0
GoTo CONT
Else
Rows(Cnt2).Insert Shift:=xlDown
END2 = END2 + 1
個数 = 0
End If
Else
If Sh2.Range("B" & Cnt2).Value = Sh2.Range("B" & Cnt2).Value Then
個数 = 個数 + 1
Else
個数 = 0
End If
End If
CONT:
Next Cnt2

Application.StatusBar = False
End Sub

No.1 回答者： t_fumiaki 回答日時： 2017/10/19 10:38

1例です。

このサイト、字下げが出来ない為、If Then Elseの入れ子が解りずらいですが・・・・。


Sub WK()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

END2 = Sh2.Range("A65536").End(xlUp).Row '最終行取得
個数 = 0

For Cnt2 = 1 To END2

If Sh2.Range("A" & Cnt2).Value <> Sh1.Range("B2").Value Then
If 個数 <> 2 Then
個数 = 0
GoTo CONT
Else
Rows(Cnt2).Insert Shift:=xlDown
END2 = END2 + 1
個数 = 0
End If
Else
If Sh2.Range("A" & Cnt2).Value = Sh2.Range("A" & Cnt2).Value Then
個数 = 個数 + 1
Else
個数 = 0
End If
End If
CONT:
Next Cnt2

Application.StatusBar = False
End Sub