| |
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 20/10/12(月) 13:12 -
