下のセルと違ったら行挿入する方法

質問

BA列に以下・左のような文字と数字が入っています。
それを同じグループ別に行挿入を行う関数かマクロを教えていただけないでしょうか。
結果的に以下・右のようにしたいのです。A列からEI列までデータが入力されているので、そこは壊さず、行挿入で対応をお願いします。（EXCEL2010）

新芝1200 　　　　　　新芝1200
新芝1200 　　　　　　新芝1200
新芝1200 　　　　　　新芝1200
新ダ1800
新ダ1800　　 　　　　新ダ1800
新ダ1800 　　　　　　　新ダ1800
新ダ1800 　　　　　　　新ダ1800
新芝1200　　　　　　　新ダ1800
新芝1200
新芝1200 　　　　　　新芝1200
新芝1200 　　　　　　新芝1200
新芝1600 　　　　　　新芝1200
新芝1600 　　　　　　新芝1200
新芝1600
新芝1600 　　　　　　新芝1600
　　　　　　　　　　　　新芝1600
　　　　　　　　　　　　新芝1600
　　　　　　　　　　　　新芝1600

回答No.1

tom04 · ベストアンサー

こんばんは！
1行目はタイトル行でデータは2行目以降にあるとします。

VBAでの一例です。
オーソドックスに

Sub 行挿入()
Dim i As Long
For i = Cells(Rows.Count, "BA").End(xlUp).Row To 3 Step -1
If Cells(i, "BA") <> Cells(i - 1, "BA") Then
Rows(i).Insert
End If
Next i
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

早速の御回答ありがとうございます。
助かりました。

回答No.6

kagakusuki

回答No.4です。

　関数を使って行を挿入した表を作る際には、データが入力されている表を元データとして使用する必要がありますので、データを入力した表自体に行を挿入する事は出来ませんから、元の表がある場所とは別の場所に、行を挿入した形で新たな表が表示される様にしなければなりません。
　ですから今仮に、Sheet1のA列～E列に元データの表が存在していて、Sheet3のA列を作業列として使用して、Sheet2のA列～E列に行を挿入した表を表示するものとします。

　まず、Sheet3のA1セルに次の関数を入力して下さい。

=IF(INDEX(Sheet1!$A:$A,ROW())="","",IF(ROW()-ROW(Sheet1!$1:$1)<1,IF(ROW()-ROW(Sheet1!$1:$1)=0,1,""),LOOKUP(9E+99,$A$1:INDEX($A:$A,ROW()-1))+1+(INDEX(Sheet1!$A:$A,ROW())<>INDEX(Sheet1!$A:$A,MATCH(9E+99,$A$1:INDEX($A:$A,ROW()-1))))))

　次に、Sheet3のA1セルをコピーして、Sheet3のA2以下に貼り付けて下さい。

　次に、Sheet2のA1セルに次の関数を入力して下さい。

=IF(COUNTIF(Sheet3!$A:$A,ROWS($1:1)),IF(INDEX(Sheet1!$A:$E,MATCH(ROW(Sheet1!$1:$1)+ROWS($1:1)-1,Sheet3!$A:$A),COLUMNS($A:A))="","",INDEX(Sheet1!$A:$E,MATCH(ROW(Sheet1!$1:$1)+ROWS($1:1)-1,Sheet3!$A:$A),COLUMNS($A:A))),"")

　次に、Sheet2のA1セルをコピーして、Sheet2のB1～E1の範囲に貼り付けて下さい。
　次に、Sheet2のA1～E1の範囲をコピーして、同じ列の2行目以下に貼り付けて下さい。

　これで、Sheet2のA列～E列に、行を挿入した表が自動的に表示されます。

お礼

詳細な御回答に感謝です。
週末、じっくり勉強させていただきます。
本当にありがとうございます。

回答No.5

kagakusuki

回答No.4です。

　済みません、「.Value」は不要でした。(「.Value」を付けたままでも正常に動作しますが)

Sub Macro()

Dim i As Long
Dim LR As Long
Dim R As Long
LR = Application.WorksheetFunction.Match("*?", Range("A:A"), -1)
R = 1
For i = 2 To LR
R = R + 1
If Range("A" & R) <> Range("A" & R - 1) Then
Range("A" & R & ":E" & R).Insert Shift:=xlDown
R = R + 1
End If
Next i

回答No.4

kagakusuki

一例ですが、次の様なマクロになります。

Sub Macro()

Dim i As Long
Dim LR As Long
Dim R As Long
LR = Application.WorksheetFunction.Match("*?", Range("A:A"), -1)
R = 1
For i = 2 To LR
R = R + 1
If Range("A" & R).Value <> Range("A" & R - 1).Value Then
Range("A" & R & ":E" & R).Insert Shift:=xlDown
R = R + 1
End If
Next i

End Sub

　尚、関数で行う方法を現在模索中です。

回答No.3

MarcoRossiItaly

No.2 です。連続ですみません。No.2 の (1) に「B1 セル」と書いてしまいましたが、正しくは「B2 セル」です。

お礼

御回答いただきありがとうございます。
凄い、このような方法があるのですね。
とても勉強になりました。

回答No.2

MarcoRossiItaly

(1) B1 セルに「=a1=a2」と記入して下方向にオートフィル、(2) B 列をコピーし B 列あるいは C 列に値複写、(3) C 列全体を選択して置換のダイアログ（Ctrl+H）により「false」→「」（未入力）と置換、(4) C3:C13 のセル範囲を選択してジャンプのダイアログ（F5）を表示し「セル選択 > 空白セル > O.K.」、(5)「セルの挿入」ダイアログ（Ctrl+Shift+ +）で「行全体」を指定し O.K.