Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

872 / 76735

←次へ　｜　前へ→


	【81524】配列で高速化したい

うなぎ

- 20/10/12(月) 13:12 -


	引用なし

	パスワード

Excel2016を使用しています。VBA初心者です。

データというシートの製品名1.列のセルを選択すると、同じ行の納入先列の入力値を、名前シート（元データ）の納入先（H列）で検索し、ヒットした行の製品名（I列）を全てAM列に抽出する。AM列のリストを選択した製品名1.列のセルに入力規則に設定するコードです（抜粋してます）。
このコードでも動いているのですが、ヒットする数が多いと非常に遅くなります。
恐らくAM列に抽出する部分を配列方式にすると高速化できると思い、ネットで同じような内容を調べて色々やってみましたが、配列方式にする部分がうまくいきません。
ご教示お願いいたします。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

　
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

Dim myRange As Range
Dim rngSearch, juhuku As Range
Dim i As Long
Dim strAdr As String
Dim rngResult As String

Dim clma, clmb, clmb2, rw As Long

clme = Range("ﾃﾞｰﾀ見出し").Find("代理店", lookat:=xlWhole).Column
clma = Range("ﾃﾞｰﾀ見出し").Find("納入先", lookat:=xlWhole).Column
clmb = Range("ﾃﾞｰﾀ見出し").Find("製品名1.", lookat:=xlWhole).Column
clmb2 = Range("ﾃﾞｰﾀ見出し").Find("製品名2.", lookat:=xlWhole).Column

If Target.Column = clmb Then '製品名1.列のセルを選択したら

　rw = Target.Row

　　　　Set myRange = Worksheets("名前").Range("H2:H500")　 '名前ｼｰﾄのH列の検索範囲をセット

　　　　Set rngSearch = myRange.Find(What:=Worksheets("ﾃﾞｰﾀ").Cells(rw, clma), lookat:=xlPart, LookIn:=xlValues)　　　'同行の納入先をH列から検索
　　　　
　　　　If rngSearch Is Nothing Then
　　　　
　　　　Exit Sub
　　　　End If
　　　
　　　　If Not rngSearch Is Nothing Then
　　　　 i = 2

　　　　　　'ヒットした値をAM列に格納
　　　　　　Worksheets("名前").Range("AM2:AM1000").Clear
　　　　　　Worksheets("名前").Cells(i, 39).Value = Worksheets("名前").Cells(rngSearch.Row, 9).Value

　　　　　　'ヒットした値のセルを退避
　　　　　　strAdr = rngSearch.Address
　　　　　　
　　　　　　　Do
　　　　　　　
　　　　　　　　Set rngSearch = myRange.FindNext(rngSearch)
　　　　　　　　If rngSearch Is Nothing Then
　　　　　　　　　　Exit Do
　　　　　　　　Else
　　　　　　　　　　 If strAdr <> rngSearch.Address Then
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　Worksheets("名前").Cells(i, 39).Value = Worksheets("名前").Cells(rngSearch.Row, 9).Value
　　　　　　　　　　 End If
　　　　　　　　End If
　　　　　　　
　　　　　　Loop While rngSearch.Address <> strAdr

　　　　　　'名前付き範囲の範囲更新
　　　　　　rngResult = "名前!" & "$AM$2:$AM$" & i
　　　　　　
　　　　　　ActiveWorkbook.Names.Add Name:="検索結果", RefersTo:="=" & rngResult

　　　　End If

　　Worksheets("ﾃﾞｰﾀ").Cells(rw, clmb).Select
　　Exit Sub

End If

　
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

Application.Cursor = xlDefault

End Sub

2 hits

▼

【81524】配列で高速化したい うなぎ 20/10/12(月) 13:12