Ｐａｇｅ 616 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼検索プログラム conan 03/1/21(火) 23:15 ┣Re:検索プログラム ぴかる 03/1/22(水) 8:58 ┃ ┗Re:検索プログラム conan 03/1/22(水) 13:50 ┃ ┗Re:検索プログラム ぴかる 03/1/22(水) 15:52 ┃ ┗Re:検索プログラム conan 03/1/22(水) 17:18 ┗このプログラムわかる方、教えてください conan 03/1/22(水) 17:15 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 2:00 ┗Re:このプログラムわかる方、教えてくださ... conan 03/1/23(木) 14:12 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 14:37 ┗Re:このプログラムわかる方、教えてくださ... conan 03/1/23(木) 15:11 ┗Re:このプログラムわかる方、教えてくださ... Jaka 03/1/23(木) 16:46 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 17:14 ┗Re:このプログラムわかる方、教えてくださ... conan 03/1/23(木) 17:46 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 18:12 ┗Re:このプログラムわかる方、教えてくださ... ワトソン 03/1/23(木) 19:50 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 20:21 ┗Re:このプログラムわかる方、教えてくださ... conan 03/1/23(木) 20:49 ┗Re:このプログラムわかる方、教えてくださ... ポンタ 03/1/23(木) 21:23 ┗修正質問 conan 03/1/23(木) 23:01 ┗Re:修正質問 ポンタ 03/1/23(木) 23:58 ┗Re:修正質問 conan 03/1/24(金) 19:51 ┗Re:修正質問 ポンタ 03/1/24(金) 21:12 ┗ラストＨＥＬＰ！（修正してみました。） conan 03/1/24(金) 23:16 ┗Re:ラストＨＥＬＰ！（修正してみました。... ポンタ 03/1/25(土) 0:31 ┗Re:ラストＨＥＬＰ！（修正してみました。... ポンタ 03/1/25(土) 0:35 ┗Re:ラストＨＥＬＰ！（修正してみました。... conan 03/1/25(土) 10:55 ┣Re:ラストＨＥＬＰ！（修正してみました。... ringtel 03/1/26(日) 19:10 ┃ ┗誤解してません？？？ conan 03/1/26(日) 19:41 ┃ ┗Re:誤解してません？？？ ゆと 03/1/27(月) 22:53 ┗Re:ラストＨＥＬＰ！（修正してみました。... ポンタ 03/1/27(月) 12:59 ┗・・・ついに conan 03/1/27(月) 13:47 ─────────────────────────────────────── ■題名 ： 検索プログラム ■名前 ： conan ■日付 ： 03/1/21(火) 23:15 -------------------------------------------------------------------------
| A列 B列 C列 D列・・・ １ アアア aaa AAA ５ イイイ bbb BBB ３ カカカ ccc FFF ４ レレレ ddd RRR ６ トトト eee LLK １２ アアア hdj KHF というデータがワークシート（A)にあるとします。 VBAでテキストボックスを作成し その中に検索する文字列を記入するようにします。 その後コマンドボタンを押して検索をスタートさせます。 検索はワークシート（A)のB列を検索の対象列として設定して もし、指定した文字列がB列にあれば、その文字がある行１列のデータを 他のワークシート（B)に抽出する。 続けてもし同じ文字列が下にもある場合は、そのデータをワークシート（B)の 先に抽出したデータの下に記入するというプログラムをVBAで書く場合は どうしたらいいのでしょうか？ （例） 検索する文字列：アアア ワークシート（B)の画面には A列 B列 C列 D列 １ アアア aaa AAA １２ アアア hdj KHF といった具合に”アアア”に関連したデータのみを表示される。 このようにしたいのですが・・・ |
| conanさん、おはようございます。 データ→オートフィルタを使って、アアアを検索してみるのはどうでしょうか？。 検索対象を変数としてマクロ化するのが、私は簡単に思います。 |
| ぴかるさん、返答有難うございます。 確かにその方法は、私もつい最近までは、使っていたんですが 列のデータが非常に多いのでオートフィルタを使って データを抽出して、最後の列のセルにカーソルを持っていって 貼り付け範囲を選択して、他のワークシートに張り付けするという 作業をするのは、とっても面倒なんです。 しかも、１つのデータ抽出だけならそんなに問題はないんですけど、 他のデータを抽出するために何度もその作業を繰り返すとなると、 かなり効率が悪くなってしまって・・・ だから、ユーザーフォームを作って、そこからデータを抽出するプログラムを 作りたいのですが。 |
| ▼conan さん： >確かにその方法は、私もつい最近までは、使っていたんですが >列のデータが非常に多いのでオートフィルタを使って >データを抽出して、最後の列のセルにカーソルを持っていって >貼り付け範囲を選択して、他のワークシートに張り付けするという >作業をするのは、とっても面倒なんです。 >しかも、１つのデータ抽出だけならそんなに問題はないんですけど、 >他のデータを抽出するために何度もその作業を繰り返すとなると、 >かなり効率が悪くなってしまって・・・ >だから、ユーザーフォームを作って、そこからデータを抽出するプログラムを >作りたいのですが。 その面倒な作業をマクロ記録して、抽出内容を変数化するのが良いと思ってご提案した次第です。オートフィルタを使わないなら、結構大変の様な気がします。私の能力では、これが限界です。あまり、お役に立てず申し訳ないです。 |
| ぴかるさん、とんでもない。 ありがとうございました。 |
| ▼conan さん： >A列 B列 C列 D列・・・ >１ アアア aaa AAA >５ イイイ bbb BBB >３ カカカ ccc FFF >４ レレレ ddd RRR >６ トトト eee LLK >１２ アアア hdj KHF > >というデータがワークシート（A)にあるとします。 >VBAでテキストボックスを作成し >その中に検索する文字列を記入するようにします。 >その後コマンドボタンを押して検索をスタートさせます。 >検索はワークシート（A)のB列を検索の対象列として設定して >もし、指定した文字列がB列にあれば、その文字がある行１列のデータを >他のワークシート（B)に抽出する。 >続けてもし同じ文字列が下にもある場合は、そのデータをワークシート（B)の >先に抽出したデータの下に記入するというプログラムをVBAで書く場合は >どうしたらいいのでしょうか？ > >（例） >検索する文字列：アアア >ワークシート（B)の画面には >A列 B列 C列 D列 >１ アアア aaa AAA >１２ アアア hdj KHF >といった具合に”アアア”に関連したデータのみを表示される。 > >このようにしたいのですが・・・ |
| ワークシート（A)にCommandButton1とTextBox1を作成し、 以下のコードをワークシート（A)のシートモジュールに貼り付けて、 お試しください。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim Ws As Worksheet Set Ws = Worksheets("B") With Application .ScreenUpdating = False Set MyRange = Range("B1", Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) Ws.Range("A:D").ClearContents If MyRange.SpecialCells(xlCellTypeVisible).Count <> 1 Then Set MyRange = Range("A2", Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Call MyRange.Copy(Ws.Range("A2")) End If Me.AutoFilterMode = False End With End Sub |
| ▼ポンタ さん： >ワークシート（A)にCommandButton1とTextBox1を作成し、 >以下のコードをワークシート（A)のシートモジュールに貼り付けて、 >お試しください。 > >Private Sub CommandButton1_Click() > Dim MyRange As Range > Dim Ws As Worksheet > Set Ws = Worksheets("B") > With Application > .ScreenUpdating = False > Set MyRange = Range("B1", Range("B65536").End(xlUp)) > Call MyRange.AutoFilter(1, TextBox1.Value) > Ws.Range("A:D").ClearContents > If MyRange.SpecialCells(xlCellTypeVisible).Count <> 1 Then > Set MyRange = Range("A2", Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) > Call MyRange.Copy(Ws.Range("A2")) > End If > Me.AutoFilterMode = False > End With >End Sub ポンタさん、お返事ありがとうございます。 ユーザーフォームに、テキストボックスとコンボボックスを作成し （コンボボックスのところに）上記のプログラムを貼り付けて実行したら、 メソッドまたはデータメンバが見つかりませんという警告が出ました。 いい忘れたんですけど、ワークシート（A)の１行目はタイトル行ですので。 |
| 原因になりそうな点を3つほど指摘させていただきます。 1.コンボボックスではなく、コマンドボタンです。 2.テキストボックスの名前は｢TextBox1｣ですか？ 3.ワークシート（B)の名前はあっていますか？(｢B｣という名前にしてあります) 以上の点を確認し、適切に修正してください。 それ以外の原因の場合はお時間を頂かないと分かりません。 |
| ポンタさん おっしゃるとおり、確かに直しましたが、 どうもうまく動いてくれないみたいです・・・ また、わかればでいいんで、 教えていただければ幸いです。 |
| こんにちは。 横レス失礼します。 >ワークシート（A)にCommandButton1とTextBox1を作成し、 >以下のコードをワークシート（A)のシートモジュールに貼り付けて、 >お試しください。 >ユーザーフォームに、テキストボックスとコンボボックスを作成し >（コンボボックスのところに）上記のプログラムを貼り付けて実行したら、 この違いだと思うんですけどね．．！ |
| そうか、ユーザーフォーム上に作ってたんですね。 ワークシート（A)にCommandButton1とTextBox1を作成し、 ~~~~~~~~~~~~~~~~ って書いたのに。 以下のコードに置き換えてください。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim WsA As Worksheet, WsB As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") With Application .ScreenUpdating = False Set MyRange = WsA.Range("B1", Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) WsB.Range("A:D").ClearContents If MyRange.SpecialCells(xlCellTypeVisible).Count <> 1 Then Call WsA.Rows(1).Copy(WsB.Range("A1")) Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Call MyRange.Copy(WsB.Range("A2")) End If WsA.AutoFilterMode = False End With Me.Hide End Sub |
| ▼ポンタ さん： >そうか、ユーザーフォーム上に作ってたんですね。 > >ワークシート（A)にCommandButton1とTextBox1を作成し、 >~~~~~~~~~~~~~~~~ >って書いたのに。 > >以下のコードに置き換えてください。 > > >Private Sub CommandButton1_Click() > Dim MyRange As Range > Dim WsA As Worksheet, WsB As Worksheet > Set WsA = Worksheets("A") > Set WsB = Worksheets("B") > With Application > .ScreenUpdating = False > Set MyRange = WsA.Range("B1", Range("B65536").End(xlUp)) > Call MyRange.AutoFilter(1, TextBox1.Value) > WsB.Range("A:D").ClearContents > If MyRange.SpecialCells(xlCellTypeVisible).Count <> 1 Then > Call WsA.Rows(1).Copy(WsB.Range("A1")) > Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) > Call MyRange.Copy(WsB.Range("A2")) > End If > WsA.AutoFilterMode = False > End With > Me.Hide >End Sub ポンタさん 上記プログラムで抽出はうまくいきました。ありがとうございます。 でも、該当データが２つ以上あるのに、１件しかシート（Ｂ）にコピーしていないんですけどどうしたらいいでしょうか。あと、シート（Ａ）の１番上はタイトル行なのですが、そのタートルも一緒に抽出データともに、シート（Ｂ）にコピーされているんですがどうしたらいいでしょうか？ |
| ＞シート（Ａ）の１番上はタイトル行なのですが、そのタートルも一緒に抽出データともに、 ＞シート（Ｂ）にコピーされているんですがどうしたらいいでしょうか？ 修正しました。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim WsA As Worksheet, WsB As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") With Application .ScreenUpdating = False Set MyRange = WsA.Range("B1", Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) WsB.Range("A:D").ClearContents If MyRange.SpecialCells(xlCellTypeVisible).Count <> 1 Then Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Call MyRange.Copy(WsB.Range("A1")) End If WsA.AutoFilterMode = False End With Me.Hide End Sub ＞該当データが２つ以上あるのに、１件しかシート（Ｂ）にコピーしていないんですけどどうしたらいいでしょうか。 こちらでテストすると、全部転記しているようです。 もし、良かったら、 1.テキストボックスになんと入力したのか。 2.該当するはずの全てのデータ(IEへコピー＆ペーストしてください)。 3.転記されたデータと転記されなかったデータ 以上3点を教えてもらえませんか？ PS.掲示板では、必要のない引用は出来るだけ省いたほうが喜ばれます。 |
| ポンタさん すいません、こちらの入力ミスで抽出が不完全になっていたようです。 すべて該当するものは、コピーされていました。 ありがとうございました。 ・・・あつかましいのですが、追加の質問があるんです。 （質問第１点） もし、テキストボックスに入力した文字列が、シート（Ａ）のデータベースになかった場合は、 if textbox1.value = emoty then msgbox("該当なし") else ’ある場合の処理 end if をどの部分に入れればいいんでしょうか？ （質問第２点） 抽出したデータをシート（Ｂ）にコピーする際、抽出したデータのうち、下から６つだけを限定して貼り付けするということは可能でしょうか。 例：↓テキストボックスに入力された文字列を合致したデータ Ａ（１） （格好内は説明上、抽出された順番とします。） Ｂ（２） Ｃ（３） Ｄ（４） Ｅ（５） Ｆ（６） Ｊ（７） 通常なら シート（Ｂ）に Ａ（１） Ｂ（２） Ｃ（３） Ｄ（４） Ｅ（５） Ｆ（６） Ｊ（７） と張り付けされますよね。そこを Ｂ（２） Ｃ（３） Ｄ（４） Ｅ（５） Ｆ（６） Ｊ（７） といったように、６つ以上該当した場合のみ シート（Ｂ）にコピーするデータを６つに限定する。ということは可能でしょうか？ |
| conanさんとワトソンさんは同一人物なのですか？ もし、そうならば、InputBoxを使うやり方か、 ユーザーフォームを使うやり方か、 どちらか一つにしていただけませんか？ 現在のところ、ユーザーフォームを使うやり方のほうが 完成形に近いので、こちらを完成させる代わりに、 【3037】抽出方法 のほうは完了とする、ということにして いただけませんか？ |
| おなじです。 ただ、同じ名前で同じような内容だとわかりにくいと思って 名前を変えて質問していたしだいです。 今すぐ、もう一つのほうは、完了にしておくので 先ほど質問しておいたのが、もしわかれば 教えていただけますか？ よろしくお願いします。 |
| 修正しました。 お試しください。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim WsA As Worksheet, WsB As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") Me.Hide With Application .ScreenUpdating = False Set MyRange = WsA.Range("B1", Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) WsB.Range("A:D").ClearContents Select Case MyRange.SpecialCells(xlCellTypeVisible).Count Case 1 MsgBox ("該当なし") Case 2 To 6 Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Call MyRange.Copy(WsB.Range("A1")) Case Else Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) Call MyRange.Copy(WsB.Range("A1")) End Select WsA.AutoFilterMode = False End With End Sub |
| ポンタさん、完璧です。本当にありがとうございます。 できれば、もう少し修正したい部分があるので、もう少しご指導よろしくお願いします。 （第１点） 今のコードでは、前回コピーしたデータは次に実行した場合クリアされていますが、そのデータを置いておきたいので、このように改良できますか？ もし、Ａ１が何か記入されていれば６つ下のＡ７から貼り付ける もし、Ａ７が何か記入されていれば６つ下のＡ１３から貼り付ける もし、Ａ１３が何か記入されていれば６つ下のＡ１９から貼り付ける もし、Ａ１９が何か記入されていれば６つ下のＡ２５から貼り付ける もし、Ａ２５が何か記入されていれば６つ下のＡ３１から貼り付ける もし、Ａ３１が何か記入されていれば６つ下のＡ３７から貼り付ける もし、Ａ３７が何か記入されていれば６つ下のＡ４３から貼り付ける もし、Ａ４３が何か記入されていれば「データはすべて埋まっています」と警告を出す。 （第２点） 今のコードは、もしＢ列に該当するものがなければ「該当なし」と出るように 改良していただいたんですが、MsgBoxのOKを押すと、マクロ自体も 終わってしまいます。OKを押したら、最初に実行したときのような画面（マクロ顔わらにようにしたい）にしたいのですが、どうしたらいいでしょうか？ （第３点） 今は、シート（Ａ）のＢ列のみを検索対象にしているんですが 今後データ量が増えたとき、シート（Ｃ）にシート（Ａ）の続きを作ろうと思っています。この場合コードはどうしたらいいでしょうか？ ちなみに、検索対象列はシート（Ａ）と同じく、Ｂ列を対象にしています。 |
| 修正しました。 お試しください。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim WsA As Worksheet, WsB As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") Me.Hide With Application .ScreenUpdating = False Set MyRange = WsA.Range("B1", WsA.Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) Select Case MyRange.SpecialCells(xlCellTypeVisible).Count Case 1 MsgBox ("該当なし") Me.Show Exit Sub Case 2 To 6 Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Case Else Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) End Select If WsB.Range("A65536").End(xlUp).Row < 48 Then If WsB.Range("A1").Value = "" Then Call MyRange.Copy(WsB.Range("A1")) Else Call MyRange.Copy(WsB.Range("A65536").End(xlUp).Offset(1, 0)) End If Else Call MsgBox("データはすべて埋まっています", vbExclamation) End If WsA.AutoFilterMode = False End With End Sub >今後データ量が増えたとき、シート（Ｃ）にシート（Ａ）の続きを作ろうと思っています。 >この場合コードはどうしたらいいでしょうか？ 意味がよく分かりません。 (A)で見つからなければ、(C)でも抽出する、ということですか？ 単純に対象を(A)→(C)に変えてしまうだけなら、 Set WsA = Worksheets("A") を書き直すだけでよいと思います。 |
| ポンタさん 毎度毎度ありがとうございます。 （質問１） 修正していただいたコードを実行してのですが Ａ１にデータがあるときの命令で、Ａ１にすぐ下のＡ２からコピーされてしまうのですが、どうしたらいいでしょうか？ できれば以下のようにしたいのですが。 もし、Ａ１が何か記入されていれば６つ下のＡ７から貼り付ける もし、Ａ７が何か記入されていれば６つ下のＡ１３から貼り付ける もし、Ａ１３が何か記入されていれば６つ下のＡ１９から貼り付ける もし、Ａ１９が何か記入されていれば６つ下のＡ２５から貼り付ける もし、Ａ２５が何か記入されていれば６つ下のＡ３１から貼り付ける もし、Ａ３１が何か記入されていれば６つ下のＡ３７から貼り付ける もし、Ａ３７が何か記入されていれば６つ下のＡ４３から貼り付ける もし、Ａ４３が何か記入されていれば「データはすべて埋まっています」 という風に命令を出す。 （質問２） >>今後データ量が増えたとき、シート（Ｃ）にシート（Ａ）の続きを作ろうと思っています。 >>この場合コードはどうしたらいいでしょうか？ > >意味がよく分かりません。 >(A)で見つからなければ、(C)でも抽出する、ということですか？ そうです。例えば シートＡの行が一杯になってしまったりすると シートＣにシートＡの続きのデータベースを記入して行きたいので。 なのでもしできれば、 （命令内容）検索対象をシート（Ａ）のＢ列をデータベースがある行まで検索して、もしＢ列の終わりがＡ６５５３６であり、もしシート（Ｃ）にデータベースが存在しているなら、シート（Ｃ）のＢ列を検索する。 そして、その２つのシートの中でテキストボックスに記入したものと同じものがあれば、抽出したデータの下から６つをシート（Ｂ）にコピーする。 という風にしたいのですが。 |
| （質問１）は修正しました。 （質問２）はご自分で修正してください。 大して難しい修正ではないです。 要求がどんどん増えるので、付き合いきれません。 Private Sub CommandButton1_Click() Dim MyRange As Range Dim PasteRange As Range Dim WsA As Worksheet, WsB As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") Me.Hide With Application .ScreenUpdating = False Set MyRange = WsA.Range("B1", WsA.Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) Select Case MyRange.SpecialCells(xlCellTypeVisible).Count Case 1 MsgBox ("該当なし") Me.Show Exit Sub Case 2 To 6 Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Case Else Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) End Select Set PasteRange = WsB.Range("A1") Do If PasteRange.Row > 44 Then Call MsgBox("データはすべて埋まっています", vbExclamation) Exit Do ElseIf PasteRange.Value = "" Then Call MyRange.Copy(PasteRange) Exit Do Else Set PasteRange = PasteRange.Offset(6, 0) End If Loop WsA.AutoFilterMode = False End With End Sub |
| ポンタさん ・・・本当ですよね。自分で書き込みしながら何度も何度も 質問しすぎだなーって思っていたんですよ（本当に） 反省します・・・。 それで、自分でわかるところまで修正してみたんですが、合っていますか？（これ、今判る範囲では限界です。） これで、この関連の質問はラストの質問なんで、もし見られたらレスお願いします。 >Private Sub CommandButton1_Click() > Dim MyRange As Range Dim MyRange2 As Range > Dim PasteRange As Range > Dim WsA As Worksheet, WsB As Worksheet,WsC As worksheet > Set WsA = Worksheets("A") > Set WsB = Worksheets("B") Set WsC = Worksheets("C") > Me.Hide > With Application > .ScreenUpdating = False > Set MyRange = WsA.Range("B1", WsA.Range("B65536").End(xlUp)) Set MyRange2 = WsC.Range ("B1", WsC.Range("B65536").End(xlUp)) > Call MyRange.AutoFilter(1, TextBox1.Value) Call MyRange2.AutoFilter(1,TextBox1.value) Select Case MyRange.SpecialCells(xlCellTypeVisible).Count & MyRange.SpecialCells(xlCellTypeVisible).Count > Case 1 > MsgBox ("該当なし") > Me.Show > Exit Sub > Case 2 To 6 Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible)&WsC.Range("A2", WsC.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) > Case Else > Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ > .End(xlDown).Offset(-5, 0).Resize(6, 4) Set MyRange2 = WsC.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) > End Select > Set PasteRange = WsB.Range("A1") > Do > If PasteRange.Row > 44 Then > Call MsgBox("データはすべて埋まっています", vbExclamation) > Exit Do > ElseIf PasteRange.Value = "" Then > Call MyRange.Copy(PasteRange) > Exit Do > Else > Set PasteRange = PasteRange.Offset(6, 0) > End If > Loop > WsA.AutoFilterMode = False > End With >End Sub |
| もう一息、ですね。 とにかくお尻から６件欲しいのですから、 先に"C"から抽出するべきです。 "C"に６件のデータがあれば、それがお尻６件分ですし、 ６件に満たなければ、"A"から補ってあげな くてはいけません。 流れを整理すると、 1."C"から抽出 ↓ 2.６件以上見つかった → 下から６件をCopyして終了 ↓ １〜５件見つかった → PasteRange へCopy(変数に見つかった件数セットしておく) ↓ │ 見つからなかった → コピーしない │ │ │ 3."A"から抽出 │ │ ↓ ↓ 4."C"で見つかった件数と"A"で見つかった件数の合計が６件以下 → 見つかったものをPasteRangeへ"Insert"を使って挿入 ↓ "C"で見つかった件数と"A"で見つかった件数の合計が７件以上 → 6 - "C"で見つかった件数分PasteRangeへInsert ↓ "C" で見つかった件数が０ → ｢該当なし｣のメッセージを出す。 ↓ それ以外の場合は、｢"C"で見つかったものが全て｣ということだから処理しない こんな感じです。 ただ、65535件以上の中からデータを抽出するとなると、 PCにかなりの負荷が掛かると思います。 以下独り言。 >付き合いきれません。 とまで、書いておきながら、出てきてしまう自分に少々あきれてるところです。 しかも、コード書くより時間掛かってるし･･･。(^_^;) |
| 【3131】、時間掛かった割には、みにくいですね。 コピーして、メモ帳に貼り付けてもらうと見やすくなります。 |
| ポンタさん 再びレス書いていただき感謝しています。 なんせここまで、私が書きたいコードの内容をすべてを説明しているのは ポンタさんしかいませんし、それを毎回書いていただいているのも ポンタさんでしたから・・・。他のＶＢＡの掲示板にも同じようなことを 質問してもなかなか意味が通じなくて、困っていたんです。 ６５５３６行まで検索させたらＰＣに負荷が大きいのですか。 う〜む、どうしましょう。データベースを分割して検索させるするか、 でもそうするとコードの量はかなり複雑になりますね・・・ ま〜その時に、なんとか考えるしかないですね。 結構考えて修正してみました。が初心者ゆえに段々頭が混乱してきちゃいました（苦笑）。 どうでしょうか？ （・・・できれば、正解も書いて欲しいです・・・（もし良ければ）） Private Sub CommandButton1_Click() Dim MyRange As Range Dim MyRange2 As Range Dim PasteRange As Range Dim WsA As Worksheet, WsB As Worksheet, WsC As Worksheet Set WsA = Worksheets("A") Set WsB = Worksheets("B") Set WsC = Worksheets("C") Me.Hide With Application .ScreenUpdating = False 'シート（Ｃ）を検索する Set MyRange = WsC.Range("B1", WsC.Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) Select Case MyRange.SpecialCells(xlCellTypeVisible).Count & MyRange2.SpecialCells(xlCellTypeVisible).Count Case 1 'シート（Ａ）を検索する Set MyRange2 = WsA.Range("B1", WsC.Range("B65536").End(xlUp)) Call MyRange2.AutoFilter(1, TextBox1.Value) Select Case MyRange2.SpecialCells(xlCellTypeVisible).Count & MyRange2.SpecialCells(xlCellTypeVisible).Count Case 1 'シート（Ｃ）及びシート（Ａ）とも該当なし MsgBox ("該当なし") Me.Show Exit Sub Case 2 To 6 'シート（Ａ）に６件以内に該当した場合の処理 Set MyRange2 = WsA.Range("A2", WsC.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Case Else 'シート（Ａ）に７件以上該当した場合の処理 Set MyRange2 = WsC.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) End Select 'シート（Ｂ）にコピーする処理 Set PasteRange = WsB.Range("A1") Do If PasteRange.Row > 44 Then Call MsgBox("データはすべて埋まっています", vbExclamation) Exit Do ElseIf PasteRange.Value = "" Then Call MyRange2.Copy(PasteRange) Exit Do Else Set PasteRange = PasteRange.Offset(6, 0) End If Loop WsA.AutoFilterMode = False WsC.AutoFilterModo = False End With Exit Sub Case 2 To 6 'シート（Ｃ）に１〜５件該当した場合の処理 ここの処理がさっぱりわかりません｡ Case Else Set MyRange2 = WsC.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) _ .End(xlDown).Offset(-5, 0).Resize(6, 4) End Select Set PasteRange = WsB.Range("A1") Do If PasteRange.Row > 44 Then Call MsgBox("データはすべて埋まっています", vbExclamation) Exit Do ElseIf PasteRange.Value = "" Then Call MyRange.Copy(PasteRange) Exit Do Else Set PasteRange = PasteRange.Offset(6, 0) End If Loop WsA.AutoFilterMode = False WsC.AutoFilterMode = False End With End Sub |
| >ポンタさんでしたから・・・。他のＶＢＡの掲示板にも同じようなことを >質問してもなかなか意味が通じなくて、困っていたんです。 他の板も見て回ってるロムの者ですが嘘はつかないでいただけますか？ ワトソンさん |
| そういう意味じゃないですよ。 私の質問したいことが文章ではなかなか相手に 伝わらなくて困っていたってことです。 ポンタさんが一番聞きたい答えと 合致していたってことです。 |
| conan さんこんばんは。 横からですみません。 おそらくマルチポストに関してのことや、HNをかえるということに 対してのことかと思います。 [#1071] [#996] などが参考になるかと思います。 |
| >大して難しい修正ではないです。 やってみると結構めんどくさかったです。(^_^;) Private Sub CommandButton1_Click() Dim MyRange As Range Dim PasteRange As Range Dim WsA As Worksheet, WsB As Worksheet Dim HitCount As Integer Set WsA = Worksheets("C") Set WsB = Worksheets("B") Me.Hide Application.ScreenUpdating = False Set MyRange = WsA.Range("B1", WsA.Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) HitCount = MyRange.SpecialCells(xlCellTypeVisible).Count - 1 Select Case HitCount Case 0 Case 1 To 5 Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Case Else Set MyRange = WsA.Range("B:B").SpecialCells(xlCellTypeVisible).End(xlDown).Offset(-5, -1).Resize(6, 4) End Select If HitCount > 0 Then Set PasteRange = WsB.Range("A1") Do If PasteRange.Row > 44 Then Call MsgBox("データはすべて埋まっています", vbExclamation) Application.ScreenUpdating = True Exit Sub ElseIf PasteRange.Value = "" Then Call MyRange.Copy(PasteRange) Exit Do Else Set PasteRange = PasteRange.Offset(6, 0) End If Loop End If WsA.AutoFilterMode = False If HitCount < 6 Then Set WsA = Worksheets("A") Set MyRange = WsA.Range("B1", WsA.Range("B65536").End(xlUp)) Call MyRange.AutoFilter(1, TextBox1.Value) Select Case MyRange.SpecialCells(xlCellTypeVisible).Count Case 1 Application.ScreenUpdating = True If HitCount = 0 Then MsgBox ("該当なし") End If WsA.AutoFilterMode = False Application.ScreenUpdating = False Me.Show Exit Sub Case Else If HitCount + MyRange.SpecialCells(xlCellTypeVisible).Count < 7 Then Set MyRange = WsA.Range("A2", WsA.Range("D65536").End(xlUp)).SpecialCells(xlCellTypeVisible) Else Set MyRange = WsA.Range("B:B").SpecialCells(xlCellTypeVisible).End(xlDown).Offset(5 - HitCount, -1).Resize(6 - HitCount, 4) End If End Select If Not MyRange Is Nothing Then Set PasteRange = WsB.Range("A7") Do If PasteRange.Row > 50 Then Call MsgBox("データはすべて埋まっています", vbExclamation) Exit Do ElseIf PasteRange.Value = "" Then MyRange.Copy PasteRange.Offset(-6, 0).Insert (xlShiftDown) Exit Do Else Set PasteRange = PasteRange.Offset(6, 0) End If Loop End If End If WsA.AutoFilterMode = False Application.ScreenUpdating = True End Sub ＞６５５３６行まで検索させたらＰＣに負荷が大きいのですか。 ＞う〜む、どうしましょう。データベースを分割して検索させるするか、 ｢７件目のデータが入力されたら、古いデータを削除する｣なんていうのはダメですよね？ |
| ポンタさん ・・・ついに完成しました！！！ 完成に至るまでに、約１週間。その間何度も何度も質問してしまって・・・申し訳なかったです。 今まで色々としつこい質問に答えていただき、 本当に本当にありがとうございました。 >｢７件目のデータが入力されたら、古いデータを削除する｣なんていうのはダメですよね？ そうですね〜。なんせ、データベース化してデータを蓄積して行っているんで。 でも、６５５３６行一杯にしようと思えば、相当な月日が掛かるので、 この問題は、後々考えていこうと思っています。 |