[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『結合したセルのオートフィルターで抽出する方法』（こた）
前回と同じコードについて質問です。
結合したセルをオートフィルターで抽出できる表を作成しています。
前回はマクロが実行できないということで、たくさんのアドバイスを頂き解決しました。ありがとうございます。
今回の質問はコードの内容についてです。
ご指摘頂けたらと思います。
コードの内容は前回同様、
１、作業列のセルQK6に＝IF(C6="",QK5,C6)を挿入。
２、オートフィルでQK209までコピー。
３、QK6〜QK209まで選択してコピー。
４、隣の列QL6〜QL209を選択して「値」で貼り付け。
５、QL6〜QL209まで選択してコピー。
６、５を結合セルC６〜C209に「数式」で貼り付け。
７、D2から抽出したい文字列を読み取り、抽出。
８、作業列 QK、QLの数式及び値の削除
・結合セルC６〜C209
・抽出の項目A5〜G５
・抽出の表の範囲A5〜G209
・作業列 QK、QL
Sub 進研､ベネッセ_名前抽出()
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
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
Selection.AutoFilter
ActiveSheet.Range("$A$5:$G$209").AutoFilter Field:=3, Criteria1:="*" & Range("D2").Value & "*"
Range("QK6:QL211").Select
Selection.ClearContents
End Sub
QLの値をC列に数式で貼りつけた時に、下記のように、空白のセルは空白のままにしたいのですが、
（QL列の値をC列に数式で貼り付け後）
C6・7（結合セル） 山田
C8・9（結合セル） 田中
C10・11（結合セル）伊東
C12・13（結合セル）鈴木
C14・15（結合セル）
C16・17（結合セル）
C18・19（結合セル）
・
・
・
C208・209（結合セル）
しかし、いまの＝IF(C6="",QK5,C6）だと当然ながら
C14・15（結合セル）以降のセルが、下記の例の場合ですと、C12・13（結合セル）の「鈴木」になってしまいます。
（QL列の値をC列に数式で貼り付け後）
C6・7（結合セル） 山田
C8・9（結合セル） 田中
C10・11（結合セル）伊東
C12・13（結合セル）鈴木
C14・15（結合セル）鈴木
C16・17（結合セル）鈴木
C18・19（結合セル）鈴木
・
・
・
C208・209（結合セル）鈴木
C６〜C209の文字列もしくは空白を読み取って、最後に数式で貼りつけるときに
空白のセルは空白のままで・・という方法はあるのでしょうか？
私自身、マクロはもちろん関数にしてもあまり理解できておらず、ネットで集めた情報を組み合わせているような状態ですので、説明が分かりにくいかとは思いますが、皆さまのご指摘や意見を頂けたらと思いますので、宜しくお願い致します。
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
要は、C列が２行ずつ結合され、そこに名前が入っている。その名前で絞り込みたい。 そういう要件ですね。
結合セルが存在する列に対して、オートフィルターをかけるということ自体は、ちょっとしたテクニック（というほどのものではないですが）で 可能です。
要件として冒頭で述べたことが正しいかどうかの確認をお願いします。
（β） 2016/09/17(土) 20:09
では以下でお試しください。 作業列は QK のみ使用。オリジナルシートには細工をせず、オリジナルシートをコピーした新規シートで作業しています。 オリジナルシート名を "Sheet1" にしてありますが、★印のところ、実際のシート名に変更してください。
Sub Sample()
Dim shN As Worksheet
Dim v() As String
Dim i As Long
Dim c As Range
Application.ScreenUpdating = False
Sheets("Sheet1").Copy After:=Sheets("Sheet1") '★
Set shN = ActiveSheet
shN.AutoFilterMode = False '念のため、いったん解除
shN.Range("A5:G209").AutoFilter '再設定 行数固定でいいのかなぁ？
'=====結合セルの隠れたセルに、表のセルの値を埋め込む
With shN.AutoFilter.Range
With .Columns(3).Offset(1).Resize(.Rows.Count - 1)
ReDim v(1 To .Rows.Count, 1 To 1)
i = 1
For Each c In .Cells
If Len(c.Value) = 0 Then
v(i, 1) = v(i - 1, 1)
Else
v(i, 1) = c.Value
End If
i = i + 1
Next
End With
End With
With shN.Range("QK1").Resize(UBound(v, 1))
.Value = v
.Copy
End With
With shN.AutoFilter.Range
.Columns(3).Offset(1).Resize(UBound(v, 1)).PasteSpecial Paste:=xlPasteFormulas
Application.CutCopyMode = False
End With
'=====埋め込み終了
shN.AutoFilter.Range.AutoFilter Field:=3, Criteria1:="*" & shN.Range("D2").Value & "*"
shN.Columns("QK").Clear
shN.Select
End Sub
（β） 2016/09/17(土) 20:37
↑のコード、こちらにある 結合セルシート上でのオートフィルター処理の一部を使いましたが 当初の、そちらの 数式埋め込みによる処理のほうが、コード数も少なく、わかりやすかったですね。
こたさん方式によるコードを以下に。（勉強になりました！）
Sub Sample2()
Dim shN As Worksheet
Dim c As Range
Dim n As Long
Application.ScreenUpdating = False
Sheets("Sheet1").Copy After:=Sheets("Sheet1") '★
Set shN = ActiveSheet
shN.AutoFilterMode = False '念のため、いったん解除
shN.Range("A5:G209").AutoFilter '再設定 行数固定でいいのかなぁ？
n = shN.AutoFilter.Range.Rows.Count - 1
'=====結合セルの隠れたセルに、表のセルの値を埋め込む
With shN.Range("QK2").Resize(n)
.Formula = "=IF(C6="""",C5,C6)"
.Value = .Value
.Copy
End With
With shN.AutoFilter.Range
.Columns(3).Offset(1).Resize(n).PasteSpecial Paste:=xlPasteFormulas
Application.CutCopyMode = False
End With
'=====埋め込み終了
shN.AutoFilter.Range.AutoFilter Field:=3, Criteria1:="*" & shN.Range("D2").Value & "*"
shN.Columns("QK").Clear
shN.Select
End Sub
（β） 2016/09/17(土) 21:07
こんばんわ。
要件は、 空欄の結合セルに一つ上の人の名前が入ってしまうのを防ぎたい。 抽出条件に合う、結合セル全てを表示したい。 ですね。
質問者さんのコードを使って、数式を修正して、後無駄なselectなどを省いてみました。
Sub 進研ベネッセ_名前抽出()
ActiveSheet.AutoFilterMode = False
With Range("QK6:QK209")
.Formula = "=IF(MOD(ROW(),2),C5&"""",C6&"""")"
.Value = .Value
.Copy
Range("C6:C209").PasteSpecial Paste:=xlPasteFormulas
.ClearContents
End With
Range("A5:G209").AutoFilter Field:=3, Criteria1:="*" & Range("D2").Value & "*"
End Sub
（sy） 2016/09/17(土) 21:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.