■VBAで条件による行挿入方法

VBA初心者です。Excel2007、XPを使用しています。

A列からQ列、平均100行程度の顧客データがあります。

F列に型番（アルファベット+数字等）が記入されており、
その型番内に「半角もしくは全角スペース」が含まれている場合、
該当があった行の下へ、該当行をコピーした内容を追加したいです。

できれば、スペースがある数だけ挿入し、
かつ該当行、挿入行に色付け出来ればなお良いです。

ご教授頂けないでしょうか。
宜しくお願い致します。

No.3 ベストアンサー 回答者： tom04 回答日時： 2013/11/21 19:09

たびたびごめんなさい。

No.2のコードで無駄な行がありました。
↓のコードに変更してください。

Sub Sample3()
Dim i As Long, k As Long, str As String
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
If InStr(Cells(i, "F"), "×") > 0 Then
Cells(i, "A").Resize(, 17).Interior.ColorIndex = 36
str = Replace(Cells(i, "F"), "×", "")
k = Len(Cells(i, "F")) - Len(str)
If k > 1 Then
Rows(i + 1 & ":" & i + k - 1).Insert
Cells(i, "A").Resize(, 17).Copy Cells(i + 1, "A").Resize(k - 1, 17)
End If
End If
Next i
End Sub

何度も失礼しました。m(_ _)m

この回答へのお礼

tom04様、ありがとうございます！

今回もイメージ通りの完璧なマクロでした。

内容はなんとなくでしか理解できませんが、
これから頑張って精進します。

本当に助かりました！

お礼日時：2013/11/21 19:52

No.2 回答者： tom04 回答日時： 2013/11/21 19:05

No.1です。

＞F列内に「×」が1つのみなら、該当行を色付けのみ
＞「×」が2つなら、1行挿入で色付け、
＞「×」が3つなら、2行挿入で色付け

「×」の個数より1行少なく挿入し、コピー＆ペーストすればよい訳ですね？
該当行にも色がつくようにしています。
結局、「×」がある行はすべて色がついてしまいますが・・・

前回同様、1行目はタイトル行でデータは2行目以降にあるとします。

Sub Sample2()
Dim i As Long, k As Long, str As String
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
If InStr(Cells(i, "F"), "×") > 0 Then
Cells(i, "A").Resize(, 17).Interior.ColorIndex = 36
str = Replace(Cells(i, "F"), "×", "")
k = Len(Cells(i, "F")) - Len(str)
If k > 1 Then
Rows(i + 1 & ":" & i + k - 1).Insert
Cells(i, "A").Resize(, 17).Copy Cells(i + 1, "A").Resize(k - 1, 17)
Range(Cells(i + 1, "A"), Cells(i + k - 1, "Q")).Interior.ColorIndex = 36
End If
End If
Next i
End Sub

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

No.1 回答者： tom04 回答日時： 2013/11/20 19:13

こんばんは！

検索するのはF列だけで良いのですよね？

F列文字列のスペースの数だけ行を挿入・挿入した行を薄い黄色にしてみました。

Sub Sample1()
Dim i As Long, k As Long, str As String
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
str = Replace(StrConv(Cells(i, "F"), vbNarrow), " ", "")
k = Len(Cells(i, "F")) - Len(str)
If k > 0 Then
Cells(i, "A").Resize(, 17).Interior.ColorIndex = 36 '←薄い黄色
Rows(i + 1 & ":" & i + k).Insert
Cells(i, "A").Resize(, 17).Copy Cells(i + 1, "A").Resize(k, 17)
End If
Next i
End Sub

※　文字列の最初・途中・最後のスペースすべてが対象となります。

こんな感じをお望みだったのでしょうか？m(_ _)m

この回答へのお礼

tom04様、早々にありがとうございます！
イメージ通りで完璧でした。

申し訳ないですが、
別のパターンで作成頂くことは可能でしょうか。

F列内に「×」が1つのみなら、該当行を色付けのみ
「×」が2つなら、1行挿入で色付け、
「×」が3つなら、2行挿入で色付け、
・・・最大「×」が5つで4行まで

作って頂いたもので出来ないか考えましたが、
私にはどうしても手に負えません。

何卒宜しくお願い致します。

お礼日時：2013/11/21 09:43