VBA 結合したセルを抽出したい

Question

上のA1:F7ような表があるとします。
ここからAdvancedFilterを用いてデータ抽出をVBAを使って行いたいのですが、J1:O5のように結合されたセルが反映されず、正しく表示されません。

作ったコードは

Sub SampleExtraction()
Dim maxRow As Long
Dim InSheet As Worksheet
Set InSheet = Worksheets("sample")
Application.ScreenUpdating = False
InSheet.Range("J:O").Clear
maxRow = InSheet.Range("A65536").End(xlUp).Row
    With InSheet.Range(Cells(1, 1).MergeArea, Cells(maxRow, 6).MergeArea)
        .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=InSheet.Range("H1:H2"), CopyToRange:=InSheet.Range("J1"), Unique:=False
    End With
Application.ScreenUpdating = True
End Sub

となっています。
ここからの改善点をお教えいただけるでしょうか?
よろしくお願いします。

Answer 1

C1セルからE1セルを結合しなくても、
セルの書式設定から
横位置を選択範囲内で中央にしたらそのように見えます。
なのでセルを結合せずに2行目をフィルターのタイトル行に使えるように、
するのが1案。

2案目は、
今のように特定の項目の特定の値だけを抽出するなら、

Sub test()
    Dim rngOld As Range
    Dim rngNew As Range
    Dim rngTarget As Range
    Dim strKey As String
    
    With Range("A1").CurrentRegion
        Set rngOld = Intersect(.Cells, .Offset(2))
    End With
    Set rngNew = Range("J2").Cells
    Let strKey = Range("H2").Value
    rngNew.CurrentRegion.Offset(1).ClearContents
    
    With rngOld     '.Columns(2)
        .Replace strKey, ""
        On Error Resume Next
        Set rngTarget = Intersect(.Cells, .SpecialCells(xlCellTypeBlanks).EntireRow)
        On Error GoTo 0
        If rngTarget Is Nothing Then Exit Sub
    End With
    
    rngTarget.Copy rngNew
    Union(rngOld, rngNew.CurrentRegion).SpecialCells(xlCellTypeBlanks).Value = strKey
End Sub

こんなやり方もあります。

が、エクセルを簡易データベースとして使うには、
データ1件→1行とし、タイトル行も含めて結合セルは使わない
ようにしましょう。

マクロでやるなら、
見せるシート
データベースとしてデータを置くシート
編集の途中を仮置きする作業用シート
と用意しておいて、
見せるシート上でいろいろ操作させて（ボタン等を押すなど）、
データを見せるように作るといいと思います。

Answer 2

結合セルは、先頭のセル（右上のセル）のみ値を持ち、他は空欄になります。
つまり、D1:F1 の結合セルは、D1 のみ値を持ち、E1 と F1 は空欄です。

AdvancedFilterは表の1行目を項目名と判断して、抽出します。
E1 と F1 は空欄ですので項目名がないと判断して、E列 F列のデータは抽出しません。

結合セルは使わずに下記のような表にすれば希望の結果を得られると思います。

どうしても結合セルにしたいのなら、結合を解除して上記の表のように項目名を代入してからAdvancedFilterを実行、その後、元の結合に戻す、というような処理にすることになります。

Answer 3

基本的には「できません」
結合セルの一番左上以外のセルの内容はクリアされますので、
そこは空白セル扱いとなります。
また、抑々項目名行が2行の表にオートフィルタは対応しておりません。

裏技は…なくはないですが正常動作する（し続ける）保証はありません。

Office TANAKA 結合セルをオートフィルタで絞り込む

その元シートの見やすさを維持する為に結合セルを維持したいのであれば、
別シートに一行の項目名行を入れ、2行目以降に 参照…=sheet1!A2
みたいな感じで一行の項目名の元データを用意して、
オートフィルタはそちらからやるのが良いかと思います。

あと、年齢で絞り込むだけであればVBAもオートフィルタも無しに、
関数だけでも実現できますよ。