VBA 結合行を削除したときに値を残したい

以下の様な処理をＶＢＡで行いたいのですが、セルの内容が消えてしまいます。どうすればよいか教えてください

　Ａ列に商品タイプがあり、Ｂ列に商品名が入力されている。
　１つの商品タイプは複数の商品があるため、Ａ列は数行単位で結合されている。
　今、マクロで特定商品の行だけを別のシートにコピーしたい。
　
　そこで、
　　シート全体をコピーし
　　コピーしたシート上で該当商品を含まない行を削除
　するマクロを作成しました。

　しかし、商品タイプの列が結合されているため、商品タイプの1行目を削除してしまうと
　新しいシート上でＡ列が空欄になってしまいます。

　該当行のみコピーすることも考えましたが、
　　商品を抜き出す表以外はそのままコピーする(この方が情報量は多い)ため、上記の方法
　　を考えました。
　
　何か良い方法はないでしょうか。
　よろしくお願い申し上げます　

No.1 ベストアンサー 回答者： tom04 回答日時： 2014/10/02 21:46

こんばんは！

＞特定商品の行だけを別のシートにコピーしたい。
すなわちB列の「特定商品」のみを別Sheetに表示したい！
というコトでしょうか？

一例です。
↓の画像のように左側がSheet1で右側のSheet2に表示するようにしてみました。
（画像ではSheet1のB列の「あ」という商品のみを表示するようにしています）
マクロでインプットボックスに「特定商品」を入力するようにしました。
標準モジュールです。

Sub Sample1()
Dim i As Long, lastRow As Long, str As String, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
str = Application.InputBox("検索商品名を入力")
.Range("A:A").Insert
.Range("A1") = .Range("B1")
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=IF(B2="""",A1,B2)"
.Value = .Value
End With
.Columns("B:B").Hidden = True
.Range("A1").AutoFilter field:=3, Criteria1:=str
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
Application.DisplayAlerts = False
For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If wS.Cells(i, "A") = wS.Cells(i - 1, "A") Then
wS.Cells(i - 1, "A").Resize(2).Merge
End If
Next i
Application.DisplayAlerts = True
wS.Range("A:A").HorizontalAlignment = xlCenter
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.AutoFilterMode = False
.Columns.Hidden = False
.Range("A:A").Delete
End With
Application.ScreenUpdating = True
End Sub

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

この回答へのお礼

早速のご回答感謝します。
知りたかったことはまさしくこれです。
ありがとうございました。

お礼日時：2014/10/03 08:03

No.2 回答者： eden3616 回答日時： 2014/10/02 22:44

添付画像のようなテストデータで行っています。

アクティブシートを隣へコピーし、結合セル解除後の空欄を各先頭項目で埋めてから、
偶数行を削除（ここは目的の削除方法に置き換えてください）して、同じ項目を再結合しています。

コード内の「'値の設定」項目で変数「strow」と「mycol」を適切に修正してからマクロ「sample」を実行してください。


■VBAコード

Sub sample()
Dim i As Long
Dim tar As Range
Dim row_max As Long
Dim key As String
Dim strow As Long
Dim mycol As String
'値の設定
strow = 2 'データの開始行
mycol = "A" '結合セルの列記号
'画面更新停止
Application.ScreenUpdating = False
'シートコピー
ActiveSheet.Copy after:=ActiveSheet
'結合セル解除
Columns(mycol).UnMerge
'最大行数取得
row_max = Cells(Rows.Count, mycol).Offset(0, 1).End(xlUp).Row
'初期値セット
Set tar = Cells(strow, mycol)
'空白を埋める
Do
　　Set tar = Range(tar, tar.End(xlDown).Offset(-1, 0))
　　If tar(tar.Count).Row > row_max Then
　　　　Set tar = tar.Resize(row_max - tar(1).Row + 1, 1)
　　　　tar = tar(1)
　　　　Exit Do
　　End If
　　tar = tar(1)
　　Set tar = tar.End(xlDown)
Loop

'偶数行を削除（この処理を目的の削除処理内容と置き換えてください）
For i = row_max To 1 Step -1
　　If i Mod 2 = 0 Then Rows(i).Delete
Next i

'セルを再結合
Set tar = Nothing
Application.DisplayAlerts = False
For i = Cells(Rows.Count, mycol).End(xlUp).Row To strow Step -1
　　If WorksheetFunction.CountIf(Range(Cells(strow, mycol), Cells(i, mycol)), Cells(i, mycol)) > 1 Then
　　　　If key <> Cells(i, mycol) Then
　　　　　　Set tar = Cells(i, mycol)
　　　　　　key = Cells(i, mycol).Value
　　　　End If
　　Else
　　　　Range(Cells(i, mycol), tar).Merge
　　　　key = Cells(i, mycol).Value
　　End If
Next i
Application.DisplayAlerts = True
'画面更新再開
Application.ScreenUpdating = True
End Sub

この回答へのお礼

早速のご回答感謝します。
ベストアンサーは最初の方に差し上げましたが、
大変参考になりました。
ありがとうございました。

お礼日時：2014/10/03 08:06