VBAの操作

質問

↓の事を行いていのでうまくいきません。
アドバイスをお願いできませんか?

変更前(Sheet1);
(A列) (B列)
1 ABC010 Data_010
2 ABC020 (同上) 'B1-B2は結合セル
3 ABC030 Data_020
4 ABC040 (同上) 'B3-B4は結合セル
.
.

変更後(Sheet2);
(A列) (B列)
1 ABC010 "OK"
2 ABC020 "OK"
3 Data_010 "Comp" '追加行
4 ABC030 "OK"
5 ABC040 "OK"
6 Data_020 "Comp" '追加行
.
.

Sheet1(B列)に値があれば、
Sheet2(A列)に結合セルの単位で値をコピーする。
Sheet2(B列)には"OK"コメント
その都度、必ず最後に行追加して結合セルの値、"Comp"コメントをコピーする.
現象は毎行、追加行が挿入されてしまいます。

Sub testVBA()
Dim i

Worksheets("Sheet1").Range("A:B").Copy
With Worksheets("Sheet2")
.Range("A1").PasteSpecial

For i = 1 To 1000
If .Cells(i, 2) <> "" Then
.Cells(i + 1, 1) = .Cells(i, 2)
.Cells(i + 1, 2) = "Comp"
　　.Cells(i, 2) = "OK"
End If
Next i
End With
End Sub

回答No.1

mt2008 · ベストアンサー

取りあえずこんな感じで作ってみました。

Sub Samsple()
　　Dim rRange As Range
　　Dim vInsertDat() As Variant
　　Dim nCount, sAddress, i

　　With Worksheets("Sheet2")
　　　　'Sheet1からSheet2への貼り付け(結合したまま）
　　　　Worksheets("Sheet1").Columns("A:B").Copy
　　　　.Range("A1").PasteSpecial

　　　　'結合セルの処理
　　　　nCount = 0
　　　　For Each rRange In .UsedRange
　　　　　　If rRange.MergeCells Then
　　　　　　　　'結合セルの一番下の行と値を配列に保存
　　　　　　　　nCount = nCount + 1
　　　　　　　　ReDim Preserve vInsertDat(1, nCount)
　　　　　　　　vInsertDat(0, nCount) = rRange.MergeArea.Item(rRange.MergeArea.Count).Row
　　　　　　　　vInsertDat(1, nCount) = rRange.Value

　　　　　　　　'結合セルをばらして結合セルの全てに「OK」と入れる
　　　　　　　　sAddress = rRange.MergeArea.Address
　　　　　　　　rRange.UnMerge
　　　　　　　　.Range(sAddress) = "OK"
　　　　　　End If
　　　　Next rRange

　　　　'行の追加
　　　　For i = nCount To 1 Step -1
　　　　　　.Rows(vInsertDat(0, i) + 1).Insert
　　　　　　.Cells(vInsertDat(0, i) + 1, 1) = vInsertDat(1, i)
　　　　　　.Cells(vInsertDat(0, i) + 1, 2) = "Comp"
　　　　Next i
　　End With
End Sub

補足

ありがとうございました。
↓のような事をおこないたいです。

変更前(Sheet1);
(D列) (E列) (K列) (V列) (W列) (X列) (Y列) (AF - AM列)
1 ABCDEF テーブル１ 　ABC456 テーブル２　 ABC789 ABC000 テーブル４
2 ABCDEF (ブランク) ABC456 (ブランク) ABC789 ABC000 (ブランク)
3 123456 (ブランク) ABC456　 テーブル３ ABC789 ABC000 テーブル５
4 123456 (ブランク) ABC456 (ブランク) ABC789 ABC000 (ブランク)
.
.
※Y1-Y2は結合セル、Y3-Y4は結合セル

変更後(Sheet2); 例では追加は3,4行目です。
(A列) (B列) 　 (C列) (D列) 　 (E列) (F列)　 (AF - AM列) (G列)
1 ABCDEF テーブル１ ABC456 テーブル２　 ABC789 ABC000 　 "OK"
2 ABCDEF テーブル１ ABC456 テーブル２ ABC789 ABC000 　 "OK"
3 ABCDEF テーブル１ 　 -　 テーブル２ ABC789 テーブル４ "Comp"　
4 123456 テーブル１ ABC456　テーブル３ ABC789 ABC000　　 "OK"
5 123456 テーブル１ ABC456 テーブル３ ABC789 ABC000 　 "OK"
6 123456 テーブル１ - 　 テーブル３ ABC789 テーブル５ "Como"
.
.
※追加は3、6行目です。

Sheet1(Y列)に値があれば、
Sheet2(G列)に対象行単位で"OK"コメントをコピーする。
必ず最後に行追加して結合セルの値、"Comp"コメントをコピーする.
現象はマージセルの処理でループしてしまいます。
ご意見をいただけないでしょうか?

-----------------
コード;

Option Explicit

Sub Sample()
Dim nRow, i, nCount, tmp, sAddress, rRange
Dim vInsertDat() As Variant

Worksheets("Sheet1").Range("D:E,K:K,V:Y,AF:AM").Copy
With Worksheets("Sheet2")
.Range("A1").PasteSpecial Paste:=xlPasteValues
nRow = .Cells(Rows.Count, 1).End(xlUp).Row 'データのある最終行

'Y列（"Sheet2"のG列）のデータ分行を追加
For i = nRow To 4 Step -1

'Y列（"Sheet2"のG列）にデータがあるか
If .Cells(i, 7) <> "" Then
tmp = .Cells(i, 7) 'G列の保管
rRange = .Range("G:G")

'G列結合セルの処理
nCount = 0
For Each rRange In .UsedRange
If rRange.MergeCells Then
'G列結合セルの一番下の行値を配列に保存
nCount = nCount + 1
ReDim Preserve vInsertDat(1, nCount)
vInsertDat(0, nCount) = rRange.MergeArea.Item(rRange.MergeArea.Count).Row
vInsertDat(1, nCount) = rRange.Value

'G列結合セルをばらして結合セルの全てに「OK」と入れる
sAddress = rRange.MergeArea.Address
rRange.UnMerge
.Range(sAddress) = "OK"
End If
Next rRange

'行の追加
.Rows(i).Copy
.Rows(i).Insert
.Cells(i + 1, 3) = "-"
.Cells(i + 1, 6) = tmp
.Cells(i + 1, 7) = "Comp"
End If
Next i
'Y列（"Sheet2"のG列）の最後尾列(Q列)への移動
.Columns(7).Cut
.Columns(17).Insert
End With
End Sub