Excel VBA質問箱 IV

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

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


9158 / 13645 ツリー ←次へ | 前へ→

【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桁の番号は重複コードはありません)

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

1件しかなかったり、1件も無い場合は動作おかしな動作になるので、
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=28412;id=excel
を参考にしてみてください。

【28755】Re:特定の条件で範囲を検索し他のセルに...
お礼  りょうた  - 05/9/13(火) 23:31 -

引用なし
パスワード
   ▼りん さん:
ご回答ありがとうございます。

>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
>
>1件しかなかったり、1件も無い場合は動作おかしな動作になるので、
>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

↑に投稿したのですが、よろしければお願いします。

9158 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free