Excel VBAでオートフィルタで抽出したデータの一部だけ貼り付けるには

質問

いつもこのコーナーでは皆様にお世話になっております。以下のＶＢＡマクロが組める方ご教示ください。

Sheet2にあるデータに複数条件でソートをかけ、ある数字（1から18まで）を入れたら、オートフィルタでＥ列のデータの選択部をSheet1のある部分に1行貼り付けるという作業です。以下のＩｎｐｕｔＢｏｘに数字を入れるところからです。

（ソート後、どの数字を入れるか判断）
↓
InputBoxにある数字"○"（1から18まで）を入れる
↓
オートフィルタＥ列「"○－"で始まる」or「"－○"で終わる」
↓
抽出されたデータのＥ列（1列だけ）のデータ（上から17個分）を選択
↓
選択部をコピー
↓
Sheet1を選択。Sheet1の"Ｋ5"セルに行列を入れ替えて貼り付け

という流れなのですが・・・

わかる方教えてください。よろしくお願いします。

回答No.4

Wendy02 · ベストアンサー

#3 は、また、ミスです。（集中力が落ちてきました。)

# 訂正後:

Dim Cr1 As Variant
Dim i As Long, c As Range

お礼

難題に対し、何度も（集中力がなくなりつつも）回答くださり頭の下がる思いでいっぱいです。今マクロを実行する時間がないのでまだ試していませんが、明日までには必ず動作確認いたします。
結果についてはまた「お礼」の欄に記載する予定です。

補足

動作確認しました。するとF1セルにある▼が青色になっており（抽出データはなし）、それをクリックして（オプション）をクリックすると

「○－」で始まる　OR　「○－」で始まる

となっていました。だからデータが抽出されないんですね！
ちなみに、▼クリック後（すべて）をクリックすると全データが表示されます。（元に戻ります）

おそらくマクロの

Criteria1:="=" & Cr1 & "-*", _
Operator:=xlOr, _
Criteria2:="=" & Cr1 & "-*"

部分がおかしいのではないかと考えられますが、いかがでしょうか？
（私にもっと力があればこの部分を修正して手直しすればいいのですが、やってみても改善できませんでした。情けない・・・）

修正できますか？おねがい致します。

回答No.3

Wendy02

すみません。変数の宣言の訂正があります。製作段階では、置いていた変数を省略しましたので、以下のように張り替えてください。

×　Dim AFilterRng As Range, Cr1 As Variant
×　Dim myPickUp, i As Long, c As Range
　　　　　↓
訂正後:

Dim As Range, Cr1 As Variant
Dim i As Long, c As Range

以上のとおりです。

お礼

＃4のあと修正しました。＃2のお礼をご覧ください。

回答No.2

Wendy02

こんにちは。

＞データが仮にB列からJ列までしかなくても、上のマクロの「With Range("A1").CurrentRegion」という記述でOKですか？

たぶん、A1に隣り合っているデータがあれば、範囲は取れますが、固定した範囲でしたら、

例:
With Range("B1:J50")

このようにした方がより良いです。

しかし、データが可変の場合は、このようにしてください。

With Range("B1", Range("B65536").End(xlUp).Offset(, 8))

この意味は、B1 とB列の最後から上に上っていって、データのあるところの範囲を、右に、J列まで拡大する、ということです。

＞右隣のF列（数値）でした。申し訳ありません。

前:　For Each c In .Range(Cells(2, 5), Cells(2, 5).End(xlDown)). _
　　　　　　　　　　　↓
　For Each c In .Range(Cells(2, 6), Cells(2, 6).End(xlDown)). _

ということになりますね。

これ以外の部分は、よろしいのですか？

お礼

回答者Wendy02さんへ
＃4のあとチャレンジして修正してみました。
するとなんとできたではありませんか！！

該当部分を

Criteria1:="=" & Cr1 & "-*", _
Operator:=xlOr, _
Criteria2:="=" & "*-" & Cr1

で行けました。ただ不思議なことにE列なのに

Field:=4で

貼り付けたい列はF列なのに

前:　For Each c In .Range(Cells(2, 5), Cells(2, 5).End(xlDown)). _

のほうで正解でした。A列に何もデータがなくB列からK列までに入っているのが原因ですかね～

何はともあれうまく行きました。ありがとうございました。とてもうれしいです。

回答No.1

Wendy02

こんにちは。

ちょっと確認しますが、
＞抽出されたデータのＥ列（1列だけ）のデータ（上から17個分）を選択

のデータは、文字列ですね。そうでないと今の方法は無理だと思います。
当然、フィールド名（1行目のタイトル名）はありますね。つまり、データの上からと言っても、E1 は、貼り付けデータとしないということです。そのように作られています。

＞Sheet1を選択。Sheet1の"Ｋ5"セルに行列を入れ替えて貼り付け

行列を入れ替えというよりは、縦のデータを横に入れ替えて貼り付けするということですね。

'---------------------------------------------------
'<なるべく標準モジュールに設定してください>
Sub PickUpSort()
　Dim AFilterRng As Range, Cr1 As Variant
　Dim myPickUp, i As Long, c As Range
　'
　Worksheets("Sheet2").Select
'--ソート後---
　'エラーチェック(この部分は必要なければ、取り除いてください)
　With Range("A1").CurrentRegion
　If .Count = 1 Then
　　MsgBox "オートフィルタは作れません.", vbCritical
　　Exit Sub
　End If
　'
　Do
　Cr1 = Application.InputBox("1～18までの数字を入れてください", Type:=2)
　If VarType(Cr1) = vbBoolean Or Cr1 = "" Then
　　Exit Sub
　ElseIf CLng(Cr1) < 1 Or CLng(Cr1) > 18 Then
　　MsgBox "1～18までの数を入れてください", vbInformation
　End If
　Loop Until CLng(Cr1) > 0 And CLng(Cr1) < 19
　.AutoFilter _
　Field:=5, _
　Criteria1:="=" & Cr1 & "-*", _
　Operator:=xlOr, _
　Criteria2:="=" & Cr1 & "-*"
　For Each c In .Range(Cells(2, 5), Cells(2, 5).End(xlDown)). _
　　SpecialCells(xlCellTypeVisible)
　　Worksheets("Sheet1").Range("K12").Offset(, i).Value = c.Value
　　If i = 17 Then Exit For
　　i = i + 1
　Next
　End With
　Beep '終了の合図
End Sub
'---------------------------------------------------

補足

すみません。ひとつ当方のミスがございました。
オートフィルタで抽出するデータはE列で「文字列」で間違いないのですが、上から17個分選択するのはその右隣のF列（数値）でした。申し訳ありません。

あとは確認事項のとおりで、

フィールド名（1行目のタイトル名）はあります。
E1 は、貼り付けデータとしないということです－でOKです。

行列を入れ替えというよりは、縦のデータを横に入れ替えて貼り付けするということです。相違ございません。

データが仮にB列からJ列までしかなくても、上のマクロの「With Range("A1").CurrentRegion」という記述でOKですか？