結合したセルのオートフィルターをVBAで。

知恵をお貸しください。

今、テストの点数表を作成しています。
下記の画像のように、結合したセルをVBAを使って抽出出来たらと考えています。

セルを結合しているので、普通に抽出すると１行になってしまいました。
そこで、ネットで調べたところ、表のセル以外のセルにIF関数を挿入、オートフィルでコピー、
コピーしたものを隣の列に「値で貼付」、表の氏名にあたるC６、７に「数式で貼付」すると
結合したままで抽出することが出来ました。

※表以外のセルAM6に、IF(C6="",AM5,C6)を挿入→オートフィルでAM7にコピー→隣の列に「値で貼付」
　
　AM5　　　　　　　　　　 AN５
　AM６山田　太郎　　　　　AN６山田　太郎
　AM７山田　太郎　　　　　AN７山田　太郎
「値で貼付」したAN６、７をコピー→氏名にあたるC６，７に「数式で貼付」

これを、オートフィルターと合わせてマクロで自動化出来ればと思うのですが、可能なのでしょうか？
名前抽出か高校名抽出のボタンを押せば、結合したセルで抽出出来るといいなと思っています。
私自身がまだ簡単なマクロしか組めないのですが、皆さんの知恵をお借り出来ればと思います。
分かりにくい文章で申し訳ありませが、宜しくお願い致します。

質問者からの補足コメント

• 

  項目が増えた為、作業列をQKとQLに変更してマクロを組み立ててみました。
  マクロの記録を使ってほぼ編集してないので、かなり拙いコードだと思います(^^;
  これを実行したところ、「このブックでマクロが使用できないか、または全てのマクロが無効になっている可能性があります。」という表示が出ました。
  マクロの設定等は変更していないのですが・・。
  コードが間違っているからとかなのでしょうか？

    補足日時：2016/09/16 19:31

• Range("QK6").FormulaR1C1 = "=IF(RC[-450]="""",R[-1]C,RC[-450])"
  Range("QK6").AutoFill Destination:=Range("QK6:QK209"), Type:=xlFillDefault
  Range("QK6:QK209").Select
  
  Selection.Copy
  Range("QL6:QL209").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Application.CutCopyMode = False
  Selection.Copy

    補足日時：2016/09/16 19:41

• Range("C6:C209").Select
  Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=False
  Range("A5:G5").Select
  Application.CutCopyMode = False
  ActiveCell.Range("A1:G1").Select

    補足日時：2016/09/16 19:43

• Selection.AutoFilter
  ActiveSheet.Range("$A$5:$G$209").AutoFilter Field:=3, Criteria1:="*" & Range("D2").Value & "*"
  Range("QK6:QL211").Select
  Selection.ClearContents
  
  文字数がオーバーして分けて投稿しました。
  見にくくてすみません。
  ご意見いただければ幸いです。

    補足日時：2016/09/16 19:44

No.3 回答者： ママチャリ 回答日時： 2016/09/17 16:48

好みにもよりますが、VBAでやるなら特にオートフィルタにこだわる必要はないと思います。

対象外の行を非表示にすれば良いだけなので…。
例えば、こんな感じです。

Sub sample()
Dim myRng As Range
Dim c As Range
Dim firstAddress As String
Application.ScreenUpdating = False
Cells.EntireRow.Hidden = False
With Range("C6:C" & Cells(Rows.Count, "G").End(xlUp).Row)
Set c = .Find(Range("D2").Value, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If myRng Is Nothing Then
Set myRng = c
Else
Set myRng = Union(myRng, c)
End If
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
If c.Address = firstAddress Then Exit Do
Loop
End If
.EntireRow.Hidden = True
End With
If Not myRng Is Nothing Then
For Each c In myRng
c.MergeArea.EntireRow.Hidden = False
Next
End If
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。
上司からの指示がオートフィルターでということですので・・。
でも、非表示でという発想が思いつかなかったので勉強になりました。

お礼日時：2016/09/18 12:18

No.2 回答者： ki-aaa 回答日時： 2016/09/17 10:23

こちらでは問題なく抽出できていますので、

貴方様のデータが、添付された図と違っているとしか考えられません。

>１行のみの抽出で名前が入っている行が全て抽出されてしまいました
のような動作はCells(1, "D")に値が記入されていたら考えられません。

この回答へのお礼

ありがとうございます。
もう一度調べてみます。

お礼日時：2016/09/17 13:14

No.1 回答者： ki-aaa 回答日時： 2016/09/16 15:58

これでどうかな

'図の左上がA1として、セルアドレスを書いています。
'AM列を作業用に使っています。


Sub 名前抽出AutoFilter()
Dim iRow As Long, xRow As Long
Dim NameCol As String
Dim FilterCol As String
Dim ArrayArea
Dim FilterRge As Range

NameCol = "C"
FilterCol = "AM"
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

xRow = Cells(Rows.Count, NameCol).End(xlUp).Row + 1
ArrayArea = Cells(1, NameCol).Resize(xRow).Value
ArrayArea(4, 1) = "作業列"
For iRow = 5 To xRow
If ArrayArea(iRow, 1) = "" Then ArrayArea(iRow, 1) = ArrayArea(iRow - 1, 1)
Next iRow


Cells(1, FilterCol).Resize(xRow).Value = ArrayArea
Set FilterRge = Range("A4:" & FilterCol & xRow)


FilterRge.AutoFilter _
Field:=Cells(1, FilterCol).Column, _
Criteria1:=Cells(1, "D").Value

End Sub

この回答へのお礼

回答ありがとうございます。
使わせて頂きましたが、１行のみの抽出で名前が入っている行が全て抽出されてしまいました(;´Д｀)

お礼日時：2016/09/16 19:14