エクセル2000のVBAのcutメゾット

質問

エクセル2000でセルを他のセルの文字から検索し検索されたセルを特定の場所にコピーし貼り付けるのを空欄になるまで繰り返すVBAを作りました。

Dim a As Range
Dim b As Long

b = 1
Do Until Cells(2 + b, 5).Value = ""
Cells(2 + b, 5).Select
Set a = Range("B:B").Find(what:=Cells(2 + b, 5).Value)
a.Select
Selection.Copy
Cells(2 + b, 8).PasteSpecial xlAll
Cells(2 + b, 5).Select
b = b + 1
Loop

なんですが、これだとちゃんと起動するのに「copy」を「cut」に変更したら、「pastespecial」でデバックが発生し止まってしまいます。
どちらかというと、コピーより切り取りして貼り付けたい（んで、残ったセルを検索しメッセージボックスで表示出せたい）のですが、このVBAだとcutメゾットは使えないのでしょうか？
また使えるのならば「pastespecial」でなければ、何を使って貼り付ければよいのでしょうか？

回答No.5

Wendy02 · ベストアンサー

こんばんは。

＞検索語が最終的に全部消えてたのですがなぜなのでしょうか?
てっきり、元は残して、検索語を消すと思い込んでいたからです。

コードを読んでいて気が付いたけれども、探すのは文字なのですね。数字ではありませんね。何か、検出される文字のヘンなことに気が付きました。
Find の中は、あまり省略しないほうがよいですね。Find のオプションは、前の検索を残していることがあって、誤動作の元になります。

Sub テスト()　マクロを読んでみました。
私として、Cutは感覚的に使えません。

改めて作り直してみました。ただ、なんとなく、すっきりとしていません。思うに、剥き出しのCells があるせいかもしれません。

これは、B3 から値の入って連続した下方向の最終行まで。
Range("B3", Range("B3").End(xlDown))

Sub TestSample2()
　Dim r As Range
　Dim b As Long
　Dim rng As Range
　Dim buf As Variant
　Set rng = Range("B3", Range("B3").End(xlDown))
　b = 3
　Do Until Cells(b, 5).Value = ""
　　Set r = rng.Find(What:=Cells(b, 5).Value, Lookat:=xlWhole)
　　If Not r Is Nothing Then
　　 Cells(b, 8).Value = r.Value
　　 r.ClearContents
　　Else
　　 buf = buf & Chr(13) & Cells(b, 5).Value
　　End If
　　b = b + 1
　Loop
　Set rng = Nothing
　MsgBox "以下が検索されていません" & buf
End Sub

お礼

再びのご回答ありがとうございます。
確かに、Cutするよりはご回答のようにしたほうが良いかもしれません。（Cutすると余計なものまでくっついてくるので）
あと、最後のメッセージボックスは検索されないものが全部一つのボックスに出せるのがすばらしいです。
このままでは、使えないのでこちらで少し書き換えました。

Sub ファイルの振り分け()

Dim a As Range
Dim b As Long
Dim c As String
Dim d As Long

For d = 5 To 44 Step 7

b = 3
Do Until Cells(b, d).Value = ""
Set a = Range("B3:B50").Find(what:=Cells(b, d).Value)
If Not a Is Nothing Then
Cells(b, d + 4).Value = a.Value
a.ClearContents
Else
buf = buf & Chr(13) & Cells(b, d).Value
End If
Cells(3, d).Resize(1, 5).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort key1:=Cells(3, d + 4), order1:=xlAscending, header:=xlNo
b = b + 1
Set a = Nothing
Loop
Next
MsgBox "以下が検索されていません" & buf

End Sub

私はまだVBA初心者なのでどこがすっきりしないか良くわからないのですが、とりあえずこれでいってみようと思います。
ご教授ありがとうございました。

回答No.4

Wendy02

こんにちは。

例えば、こんに風にしたらどうでしょう？

Dim a As Range
　Dim b As Long
　b = 1
　Do Until Cells(2 + b, 5).Value = ""
　　On Error Resume Next
　　Cells(2 + b, 8).Value = _
　　　 Range("B:B").Find(what:=Cells(2 + b, 5).Value).Value
　　If Err.Number = 0 Then Cells(2 + b, 5).ClearContents
　　On Error GoTo 0
　　b = b + 1
　Loop

お礼

ご回答ありがとうございます。
試してみたいのですが、なぜか検索語が最終的に全部消えてたのですがなぜなのでしょうか？

結局、下のお礼のようにしてみました。

回答No.3

KenKen_SP

こんにちは。KenKen_SP です。

こんな感じでしょうか。

Dim a As Range
Dim b As Long

b = 3 '処理開始行
Do Until Cells(b, 5).Value = ""
　　Set a = Range("B:B").Find(What:=Cells(b, 5).Value)
　　'見つかったときだけCut
　　If Not a Is Nothing Then
　　　　a.Cut Destination:=Cells(b, 8)
　　End If
　　b = b + 1
　　Set a = Nothing
Loop

実行速度の点から言えば、Findメソッドの検索範囲を絞った方が
良いかも。例えば、

Dim rngSearch as Range

とでも宣言しておいて

'検索範囲
Set rngSearch = Range("B3:B" & Cells(3,"B").end(xlDown).Row)

で検索範囲をオブジェクト変数に格納しておきます。
そして、上記のコードで言えば

　　Set a = Range("B:B").Find(What:=Cells(b, 5).Value)

を

　　Set a = rngSearch.Find(What:=Cells(b, 5).Value)

とします。検索範囲は小さければ小さいほど処理速度は早くなります。

お礼

エラー処理までしていただきありがとうございます。

検索範囲ですが、このＶＢＡを違う表にも対応させるため（等間隔においてFor~nextステートメントで回すつもり）終点にしてしまうと、次の表に対応できなくなっちゃうので、範囲は考えうる最大値として("B3:B50")としてみました。
これ以上ファイルが増えることはないと思うので。

複数の処理を最終的に一つのＶＢＡとしてまとめるつもりなので処理速度は出来るだけ早くしたいと考えてます。
適切なご指摘ありがとうございました。

結局、下のようなものにしてみました。（ないときの処理を増やしてみました）

Sub テスト()

Dim a As Range
Dim b As Long
Dim c As String

b = 3 '処理開始行
Do Until Cells(b, 5).Value = ""
Set a = Range("B3:B50").Find(What:=Cells(b, 5).Value)
'見つかったときだけCut
If Not a Is Nothing Then
a.Cut Destination:=Cells(b, 8)
Else
c = Cells(b, 5).Value
MsgBox c & "のファイルが検索されていません" End If
b = b + 1
Set a = Nothing
Loop
End Sub

回答No.2

hana-hana3

>a.Select
>Selection.Copy
>Cells(2 + b, 8).PasteSpecial xlAll

を、
a.Copy Cells(2 + b, 8)
の一行に。

なお、実行速度向上のために、
>a.Select
>Selection.Copy
は、a.Copy の一行で書くことが出来ます。

＞残ったセルを検索しメッセージボックスで表示出せたい

意味が良くわかりませんので・・・。

検索で見つからない場合のエラー処理がされていませんので、見つからない場合は必ずエラーで止まりますよ。
きちんとサンプルを見てエラー処理をした方が安全です。

お礼

ご回答ありがとうございました。
一応Ｃｏｐｙはうまくいったので、Ｃｕｔの仕方だったのですが、参考にさせていただきました。

結局
a.Cut Cells(2 + b, 8)
としたらうまく作動しました。
やっぱり行が少ないほうが実行速度は速くなるんですね。

言葉が足りなかったみたいですみません。
「残ったセルを選択してメッセージボックスうんぬん」は、説明しにくいのですが、検索されるセルに検索されないセルが残った場合です。

検索する表にはこのＶＢＡの前にあるフォルダからすべてのファイルをリンクするＶＢＡでファイルのリンクが書かれておりそれをファイルの一部分の文字（表で入っている）で検索し、そのファイルの一部分が入った表に貼り付けてます。（入っているフォルダは同じだがたまに処理が違う例外があるため何種類かの表が作成されている）

そのファイルがたまに増減するので、増えた場合は検索する語以外のリンクが入ってしまいます。
それを確認したいために増えて検索されなかったファイルをメッセージボックスで表示したいと考えています。

検索で見つからない場合（減った場合）のエラー処理は（というか、Ifで分岐させる予定ですが）これからしようと思ってます。

あとサンプルって何のサンプルのことでしょうか？ヘルプですか？
私は参考書を見て書いているのですが、参考書には検索時のエラー処理は書かれていませんでした。（言われるまでそっちのエラー処理を忘れていたのでご進言ありがとうございます）自分で考えるかネットでどうにかし様と思います。（未だにヘルプの使い方がよくわからないので）

ありがとうございました。

回答No.1

fly_moon

>Selection.Copy
>Cells(2 + b, 8).PasteSpecial xlAll

を
Selection.Cut
Cells(2 + b, 8).Select
ActiveSheet.Paste

にされてはいかがでしょう？

お礼

ご回答ありがとうございます。

結局
a.Cut Cells(2 + b, 8)
としたらうまく作動しました。
分ける場合はシートを指定しないといけないんですね。