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

質問

今週質問タイトルの件で回答いただき解決したのですが、更なる操作を希望したく質問させていただきました。内容は

Sheet2にあるデータに複数条件でソートをかけ、ある数字（1から18まで）を入れたら、オートフィルタでＥ列のデータの選択部をSheet1のある部分に1行貼り付けるという作業です。以下のＩｎｐｕｔＢｏｘに数字を入れるところからです。
（ソート後、どの数字を入れるか判断）
↓
InputBoxにある数字"○"（1から18まで）を入れる
↓
オートフィルタＥ列「"○－"で始まる」or「"－○"で終わる」
↓
抽出されたデータの右隣のＦ列（1列だけ）のデータ（上から17個分）を選択
↓
選択部をコピー
↓
Sheet1を選択。Sheet1の"Ｋ5"セルに行列を入れ替えて貼り付け

というものでしたが、これはできました。ここから先です。

Sheet1のＵ5セルに先ほどインプットした数字"○"（1から18までのどれか）を入れる
↓
Sheet2にてオートフィルタＥ列「"○－"で始まる」or「"－○"で終わる」によって抽出されたデータの一番上の文字列から「"○－"」もしくは「"－○"」を除いて残った数字（○を除く1から18までの数字）をSheet1のＷ5セルに（先ほどのセルとは1個飛ばして）入れる
↓
以下抽出されたデータの上から2番目の文字列を同様に操作し、1個飛ばしのセルＹ5に入れる。これがBC5セルまで続く

というものです。難しいとは存じますが、どなたか教えていただけませんか？
よろしくお願いいたします。

回答No.4

Wendy02 · ベストアンサー

こんにちは。
＞そこでひとつ飛ばしにデータを入れる形をとればうまく収まると考えて上記の質問を行った次第です。

確かに、昨日の並べ替えと同じように、言葉では、そのとおりには違いないのですが、やはり普段私などが書くコードと違ってきます。そのままでは、うまくいかないと思います。早い話、セル指定しないといけないということです。(それ以外は分かりません)　
論より証拠です、以下をみてください。

書き出し位置に関しては、もう一度点検してください。
'---------------------------------------------------------------------------
'<標準モジュール>
Sub PickUpSort4()
　Dim Cr1 As Variant, Rng As Range, ret As Variant
　Dim i As Long, j As Long, k As Long, c As Range, myData() As Variant
　Dim myDataI As String
　'最初のシート
　With Worksheets("Sheet2")
　　.Select
'フィルターモードの解除
'　　If Not .AutoFilter Is Nothing Then
'　　　.AutoFilter.Range.AutoFilter
'　　End If
　　'オートフィルタの範囲の取り直し(範囲の固定でも良い)
　　Set Rng = .Range("B1", Range("B1").End(xlDown).Offset(, 4))
　　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
　　'オートフィルタ
　　Worksheets("Sheet1").Range("U5").Value = Cr1
　　Rng.AutoFilter _
　　Field:=4, _
　　Criteria1:="=" & Cr1 & "-*", _
　　Operator:=xlOr, _
　　Criteria2:="=" & "*-" & Cr1
　　'
　　'検索数のチェック
　　'B2～下にチェック
　　ret = Application.Subtotal(3, Range(Cells(2, 6), Cells(2, 6).End(xlDown)))
　　If ret = 0 Then
　　　MsgBox "該当のものがなかったようです。", vbInformation
　　　Exit Sub 'なかったら終了
　　End If
　　On Error Resume Next
　　'Cells(2,5 ) = E2 ～
　　For Each c In .Range(Cells(2, 5), Cells(2, 5).End(xlDown)). _
　　　SpecialCells(xlCellTypeVisible)
　　　ReDim Preserve myData(k)
　　　myData(k) = c.Value
　　　k = k + 1
　　Next c
　　'データ貼り付け　U11～
　　Worksheets("Sheet1").Range("U11").Resize(, 17).Value = myData(i)
　　'-以降・以前の文字抜き出し
　　For j = 0 To 18 '配列用に 17 = 18-1 (データは、18個)
　　　myDataI = Application.Substitute(myData(j), Cr1 & "-", "")
　　　myDataI = Application.Substitute(myDataI, "-" & Cr1, "")
　　　'Cell(5,21) = U-V ～　結合セルに対して
　　　Worksheets("Sheet1").Cells(5, 21 + j * 2).Value = myDataI
　　Next
　End With
　Set Rng = Nothing
　Beep '終了の合図
End Sub
'---------------------------------------------------------------------------

最後に、
「後出しで、「結合セル」の話を言うと、複数の人にクレームが付けられるくらい……」、コードを書いている人ならともかく、このクレームをする人たちが、一体、どのぐらいの裏付けがあるのかは私には分かりません。私の知っている限りでは、Microsoft社(本社)が、結合セルのあるシートでエラーが起こる問題に対して、97以降、ずっとまったく手付かずにいるということは確かです。

＞追伸：昨日締め切った並べ替えの件ですが、やはり今職場でブックを開いてリストを見るとちゃんとあるんです。なんで家のパソコンだとなくなるのでしょうか？不思議です。

入れた並び替えリストがなくなるということですね。
システムや一部のフォルダやファイルに保護機能をつけていませんか？

お礼

試行錯誤（いろいろ手直し）した結果、またまたうまくいきました。
ありがとうございました。

並び替えリスト－保護機能の件に関しては、後日確認してみます。

Wendy02さんに教えていただいたマクロを、同じ操作で今度は別のセルを対象に続けて行いたい場合、そのまま同じプロシージャ内（モジュール内？）にそのままコピペして数字だけ変えようとしたら、コンパイルエラー「同じ適用範囲内で宣言が重複しています」とでます。

決まりでだめなんだな～というのは理解できますが、その場合変数を変更していって土壷にはまりそうなので(実際やりかけて失敗しました）、それぞれを別のプロシージャ内に記述しつつ、一つ目が終わったらCallステートメントを使って次のプロシージャを呼び出してマクロを実行させたほうがいいのでしょうか？(といってもCallステートメントを使ったことがないので自信がないですが・・・）

他の方の質問にも精力的に回答されているようなので、無理にお返事は要求いたしません。

私もおとといから昨日にかけて体がだるかった（風邪を引きかけた）のですが、回復したようです。Wendy02さんもお体にはご自愛くださいませ。

回答No.3

Wendy02

こんばんは。

＞2-14、1-2、2-9、2-11・・・
＞14、1、9、11・・・という形で貼り付けたいというのが質問の意図です。

それは、なんの問題もないです。
(やはり、この場合は、Value としてはっきりしていますので、ワークシート関数で処理するのが、もっとも速いのではないか、と考えています。)

ところで、
＞自分が入れたいセルは結合したりしていたので、なかなか思うようにデータの貼付ができなかった

一般のVBA掲示板によっては、後出しで、「結合セル」の話を言うと、複数の人にクレームが付けられるくらい、嫌われものです。VBAを使う場合は、なるべく「結合セル」は使わないほうがよいと言われています。「結合セル」の処理は、コードは複雑になりますね。こちらのコードは、まだ、がっちり固めてはいませんので、そんなに問題視はしていませんが、対処しなくてはなりません。

それと、それに関して、あまり知られていないExcelのバグがあるので、使い方によっては気をつけなくてはなりません。

結合セルの位置情報など、少し詳しく教えていただけませんか？
どこに、それが出てくるのですか？　Sheet1 側ですね？
右にデータを入れていく範囲にあるのですか？

事前に情報をください。お願いします。

補足

おはようございます。（7/8　10：15）
結合セルはSheet1の5行目のＵＶ，ＷＸ，ＹＺ，ＡＡＡＢ，・・・ＢＣＢＤまで2つのセルを結合してひとつのセルにしています（計18個）。結合しているものはカーソルを表示すると前のほうを表示しますが（Ｕ5とＶ5を結合したセルはカーソルを持ってくるとＵ5表示）マクロの記録をしてみてコードを参照してみるとＵ5：Ｖ5と選択しているんですね。そこでひとつ飛ばしにデータを入れる形をとればうまく収まると考えて上記の質問を行った次第です。あさはかだったかな～？

しかし「後出しで、「結合セル」の話を言うと、複数の人にクレームが付けられるくらい、嫌われものです。VBAを使う場合は、なるべく「結合セル」は使わないほうがよいと言われています」
という内容はまったく知りませんでした。この世界の常識を教えていただきありがとうございます。無知は怖いですね。

追伸：昨日締め切った並べ替えの件ですが、やはり今職場でブックを開いてリストを見るとちゃんとあるんです。なんで家のパソコンだとなくなるのでしょうか？不思議です。

回答No.2

Wendy02

こんばんは。

＞とりあえず今実行してみたところ、7行目でエラー「オブジェクトが必要です」と出ました。

If Not .AutoFilter Is Nothing Then

そのエラーは、<標準モジュール> で、If Not AutoFilter Is というように「.(ピリオド)」抜きで書くか、

With Worksheets("Sheet2") の後に、Range(範囲)など加えたのかしなければ、「オブジェクトが必要」というエラーは出ません。

以下の部分は取ってしまっても、全体にはまったく影響はありませんが、気になるようでしたら、ローカルウィルンドウで、自己解決してほしいです。それは、シートに、AutoFilterプロパティが存在する限りは、エラーはありえませんので、見当がつきません。

　If Not .AutoFilter Is Nothing Then
　　.AutoFilter.Range.AutoFilter
　End If

自己解決の仕方は、変数に、Dim buf などと、任意の名前をつけ加え、エラーの出る前のコードの手前に

このようなコードで、
Set buf = Worksheets("Sheet2").AutoFilter
　Stop

で、ローカルウィンドウに、buf が、Nothing と出るかでないかを調べます。

それで、Ok なら、Worksheets("Sheet2") を取って、どうなるか調べれば分かるかと思います。

＞のRange("K12")はどういう意味でしょうか？

#Worksheets("Sheet1").Range("K12").Offset(, i).Value = c.Value
　　　　　　　　　　　　　　　↑
　　　　　　　　　　　　　　　"K5"

に、なおしてください。前回でやっていたものをそのまま写しただけです。意味はありません。

#　Set Rng = .Range("A1").CurrentRegion
は、固定範囲に直すか
Set Rng = .Range("B1", Range("B1").End(xlDown).Offset(, 4))
　などとすればよいです。

#　Field:=5, _

4に直してください。

補足

おかげさまで、かなりやりたいことが出来てきました。先ほどのエラーは難なくクリアされた模様です。

自分が入れたいセルは結合したりしていたので、なかなか思うようにデータの貼付ができなかったので、別の結合などしていないセルへ貼付たらきちんとデータを貼付てくれました。（ただし、ひとつ飛ばしには入れてくれませんでしたが）おそらく(中の数字は編集しました）

'Cells(2,5 ) = E2 ～
For Each c In .Range(Cells(2, 5), Cells(2, 5).End(xlDown)). _
SpecialCells(xlCellTypeVisible)
Worksheets("Sheet1").Range("U11").Offset(, i).Value = c.Value
If i = 17 Then Exit For
i = i + 1
Next

にデータが該当したためそのようになるのでしょう。

ここまでは出来ましたが、その貼付られたデータは○が2の場合
2-14、1-2、2-9、2-11・・・と「2-」もしくは「-2」を除いた残りの数字の形にはなっていません。
14、1、9、11・・・という形で貼り付けたいというのが質問の意図です。

このケースは可能でしょうか。

回答No.1

Wendy02

okkouta 様、Wendy02 です。

前回は、終始、ボンミスばかりで、何か助けられちゃいましたが、その節は失礼しました。Wordの再インストールの際に、Excelも、何かリフレッシュになっちゃったけれど、私自身はどうも、まだぼんやりしています。でも、よろしくお願いします。m(__)m

'前回の続きからです。PickUpSort2 は、公開していません。
今度は、ミスがないことを祈って公開します。

'<標準モジュール>
Sub PickUpSort3()
　Dim Cr1 As Variant, Rng As Range, ret As Variant
　Dim i As Long, j As Long, c As Range
　'最初のシート
　With Worksheets("Sheet2")
　　.Select
　　If Not .AutoFilter Is Nothing Then
　　　.AutoFilter.Range.AutoFilter
　　End If
　　'オートフィルタの範囲の取り直し(範囲の固定でも良い)
　　Set Rng = .Range("A1").CurrentRegion
　　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
　　'オートフィルタ
　　Worksheets("Sheet1").Range("U5").Value = Cr1
　　Rng.AutoFilter _
　　Field:=5, _
　　Criteria1:="=" & Cr1 & "-*", _
　　Operator:=xlOr, _
　　Criteria2:="=" & "*-" & Cr1
　　'
　　'検索数のチェック
　　ret = Application.Subtotal(3, Range(Cells(2, 6), Cells(2, 6).End(xlDown)))
　　If ret = 0 Then
　　　MsgBox "該当のものがなかったようです。", vbInformation
　　　Exit Sub　'なかったら終了
　　End If
　　On Error Resume Next
　　'Cells(2,6 ) = F2 ～
　　For Each c In .Range(Cells(2, 6), Cells(2, 6).End(xlDown)). _
　　　SpecialCells(xlCellTypeVisible)
　　　Worksheets("Sheet1").Range("K12").Offset(, i).Value = c.Value
　　　If i = 17 Then Exit For
　　　i = i + 1
　　Next
　　On Error GoTo 0
　　'選ばれなかったもの
　　For Each c In .Range(Cells(2, 6), Cells(2, 6).End(xlDown))
　　　If c.EntireRow.Hidden = True Then
　　　　Worksheets("Sheet1").Range("W5").Offset(, j * 2).Value = c.Value
　　　End If
　　　If j = 17 Then Exit For
　　　j = j + 1
　　Next
　End With
　Set Rng = Nothing
　Beep '終了の合図
End Sub

P.S. ちょっとコードが、長くなりすぎましたね。処理を機能的に考えると、Sort　と　AutoFilterと、その後の値コピーには、あまり関連性がないので、それらは３つのサブルーチンに別けてもよさそうです。

お礼

すみません。上の補足の追加です。上のマクロの一文

Worksheets("Sheet1").Range("K12").Offset(, i).Value = c.Value

のRange("K12")はどういう意味でしょうか？

補足

とりあえず今実行してみたところ、7行目でエラー「オブジェクトが必要です」と出ました。

If Not .AutoFilter Is Nothing Then

あと、前回の補足かお礼にも書いたのですが、Ａ列にはデータがないので、E列は　Field:=4　のようです。

このマクロだと「オートフィルタの範囲の取り直し」とありますが、前回のプログラムでせっかくいい塩梅に抽出できているのでそこからダイレクトに今回の質問事項に移行はできませんか？