Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9157 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【28745】特定の条件で範囲を検索し他のセルにコピー りょうた 05/9/13(火) 22:00 質問[未読]
【28749】Re:特定の条件で範囲を検索し他のセルにコ... りょうた 05/9/13(火) 22:24 質問[未読]
【28750】Re:特定の条件で範囲を検索し他のセルにコ... りん 05/9/13(火) 22:36 発言[未読]
【28755】Re:特定の条件で範囲を検索し他のセルにコ... りょうた 05/9/13(火) 23:31 お礼[未読]
【28794】Re:特定の条件で範囲を検索し他のセルにコ... りん 05/9/14(水) 21:03 回答[未読]
【28806】Re:特定の条件で範囲を検索し他のセルにコ... Hirok 05/9/15(木) 7:13 回答[未読]
【28948】Re:特定の条件で範囲を検索し他のセルに... アイエネス 05/9/19(月) 14:03 回答[未読]
【29032】Re:特定の条件で範囲を検索し他のセルにコ... りょうた 05/9/21(水) 23:06 お礼[未読]
【28745】特定の条件で範囲を検索し他のセルにコピ...
質問  りょうた  - 05/9/13(火) 22:00 -
引用なし
パスワード
   こんばんわ。どうしてもうまくいかないので
どなたか、教えていただけないでしょうか？

★あるデータから抽出した4桁の番号が"A5"からした方向にあります。
（どのセルまであるかは、場合によって違います）
★そのデータの範囲を検索し、1*** のように、1から始まる4桁の番号が
あるセルをコピーして、"D5"にコピーしたいのです。
（4桁の番号は重複コードはありません）

Sub てすと()

Dim add As String
Dim rng As Range
Dim z As Long
Dim n As Long
　　　　　
n = 0
z = Range("A5").End(xlDown)
　　　　　
Set rng = Range("A5:L" & z).Find(What:="1*")　　
If rng Is Nothing Then
Exit Sub
Else
add = rng.Address
End If
　　　　　
Do Until rng Is Nothing
rng.Copy
Range("D5").Offset(n).PasteSpecial Paste:=xlPasteValues
n = n + 1
　　　　　
Set rng = Range("A5:A" & z).FindNext(rng)
If add = rng.Address Then
Exit Do
End If
Loop

End Sub

上記ですと、まず検索が1001のような場合だけではなく、2001のような
1が含まれるセルは全て抽出してしますのです。

次に、ループが終わらずに、何度も、同じセルをコピーして
どんどん下に貼っていくのです。

どなたか、ご指南よろしくお願いいたします。
【28749】Re:特定の条件で範囲を検索し他のセルに...
質問  りょうた  - 05/9/13(火) 22:24 -
引用なし
パスワード
   すみません。慌てて書いたので
　　　　　
>Set rng = Range("A5:A" & z).Find(What:="1*")　

↑の間違いです。　("A5:L" & z)

となってました。

どうかよろしくお願いいたします。
【28750】Re:特定の条件で範囲を検索し他のセルに...
発言  りん E-MAIL  - 05/9/13(火) 22:36 -
引用なし
パスワード
   りょうた さん、こんばんわ。

>こんばんわ。どうしてもうまくいかないので
>どなたか、教えていただけないでしょうか？
>
>★あるデータから抽出した4桁の番号が"A5"からした方向にあります。
>（どのセルまであるかは、場合によって違います）
>★そのデータの範囲を検索し、1*** のように、1から始まる4桁の番号が
>あるセルをコピーして、"D5"にコピーしたいのです。
>（4桁の番号は重複コードはありません）

４桁が数値なら、フィルタを使えば簡単です。

Sub Macro1()
　 With Range("A5")
　　　Range(.Offset(0, 0), .End(xlDown)).AutoFilter Field:=1, Criteria1:=">=1000", Operator:=xlAnd, Criteria2:="<=1999"
　　　Range(.Offset(0, 0), .End(xlDown)).Copy
　　　.Offset(0, 3).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
　 End With
　 ActiveSheet.AutoFilterMode = False
End Sub

１件しかなかったり、１件も無い場合は動作おかしな動作になるので、
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=28412;id=excel
を参考にしてみてください。
【28755】Re:特定の条件で範囲を検索し他のセルに...
お礼  りょうた  - 05/9/13(火) 23:31 -
引用なし
パスワード
   ▼りん さん：
ご回答ありがとうございます。

>４桁が数値なら、フィルタを使えば簡単です。
>
>Sub Macro1()
>　 With Range("A5")
>　　　Range(.Offset(0, 0), .End(xlDown)).AutoFilter Field:=1, Criteria1:=">=1000", Operator:=xlAnd, Criteria2:="<=1999"
>　　　Range(.Offset(0, 0), .End(xlDown)).Copy
>　　　.Offset(0, 3).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
>　 End With
>　 ActiveSheet.AutoFilterMode = False
>End Sub
>
>１件しかなかったり、１件も無い場合は動作おかしな動作になるので、
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=28412;id=excel
>を参考にしてみてください。

ご指摘のとおり

データが1件しかない場合や1件もない場合は
おかしくなってしまいます。
現在、
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=28412;id=excel
を参考にしながら、試みておりますが
まだ、うまくいきません。
オートフィルタ自体を使用したことがなかったので・・・・。
がんばってみますが、行き詰まったら
また、お願いします。
【28794】Re:特定の条件で範囲を検索し他のセルに...
回答  りん E-MAIL  - 05/9/14(水) 21:03 -
引用なし
パスワード
   りょうた さん、こんばんわ。

>データが1件しかない場合や1件もない場合は
>おかしくなってしまいます。
それ以外にも、A5からオートフィルタをかけると、A5はタイトルとして無条件で貼り付け対象になるので修正しました。

Sub TEST()
　 Dim r1 As Range, r2 As Range
　 '
　 With Range("A4")
　　　Range(.Offset(0, 0), .Offset(1, 0).End(xlDown)).AutoFilter _
　　　　 Field:=1, Criteria1:=">=1000", Operator:=xlAnd, Criteria2:="<=1999"
　　　'
　　　If Not .End(xlDown).Row = .Parent.Rows.Count Then
　　　　 On Error Resume Next
　　　　 Set r1 = Range(.Offset(1, 0), .Offset(1, 0).End(xlDown)) _
　　　　　　　　　　　　　　　　　　　　　.SpecialCells(xlCellTypeVisible)
　　　　 On Error GoTo 0
　　　End If
　 End With
　 If Not r1 Is Nothing Then
　　　r1.Copy
　　　Range("D5").PasteSpecial xlPasteValues
　 Else
　　　MsgBox "該当なし", vbExclamation
　 End If
　 '
　 ActiveSheet.AutoFilterMode = False
　 Application.CutCopyMode = False
End Sub

こんな感じです。
【28806】Re:特定の条件で範囲を検索し他のセルに...
回答  Hirok  - 05/9/15(木) 7:13 -
引用なし
パスワード
   おはようございます。
これも、シンプルです。一度試してみてください。

Sub test3()　
Dim R As Range
Dim MyR As Range
Dim i As Integer

Set MyR = Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp))
For Each R In MyR
　If R.Value > 999 And R.Value <= 1999 Then
　　i = i + 1
　　Cells(4, 4).Offset(i) = R.Value
　End If
Next
End Sub
【28948】Re:特定の条件で範囲を検索し他のセルに...
回答  アイエネス  - 05/9/19(月) 14:03 -
引用なし
パスワード
   こんにちは。

>★あるデータから抽出した4桁の番号が"A5"からした方向にあります。
>（どのセルまであるかは、場合によって違います）
→4桁の番号しか入らないのであれば、元のコードをちょっといじるだけで
いけますよ。


>Sub てすと()
>
中略
>　　　　　
>Set rng = Range("A5:A" & z).Find(What:="1*")　　
→これを下記の様に修正します。

Set rng = Range("A5:A" & z).Find(What:="1???")

ちなみに、


>z = Range("A5").End(xlDown)
ではなくて、

z = Range("A5").End(xlDown).Row

ですね。

残念ながら、小生の環境では永久ループに陥らなかったので、ループが終わらない原因は
わかりかねますが、

>Do Until rng Is Nothing
と
>If add = rng.Address Then
にブレークポイントを設定して、変数の値がどうなっているのか見てみると原因がわかる
かもしれません。
【29032】Re:特定の条件で範囲を検索し他のセルに...
お礼  りょうた  - 05/9/21(水) 23:06 -
引用なし
パスワード
   どうもアドバイスありがとうございました。

なんとか、うまく出来ました。
お礼が遅くなってしまいすみませんでした。

実は、また・・それから先で詰まってまして
今回抽出した4桁のコードを使用して
貼り付けを行いたいのですが
うまくいきません。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=29025;id=excel

↑に投稿したのですが、よろしければお願いします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9157 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free