VBA 条件抽出が遅い

Question

2つのブックがありそれぞれ総当たり表の間で条件抽出を行おうとしているのですが、動作が遅いため早くする方法などお教えいただければ幸いです。

| A B C a c
a あ え つ B
b い じ か C
c お さ き

 　 Sub 条件（）
    Dim bk1, bk2 As Workbook
    Dim sh1, sh2 As Worksheet
    Dim Keyval, keyval2 As String
    Dim i, s, x, y, z As Long
    Dim str As String, del As String

    Set bk1 = Workbooks("A")
    Set bk2 = Workbooks("B")
    
    Set sh1 = bk1.Worksheets("情報") 
    Set sh2 = bk2.Worksheets("結果")
     On Error Resume Next
    R1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 
    R2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
    C1 = sh1.Range("A1").End(xlToRight).Column
    C2 = sh2.Range("A1").End(xlToRight).Column

     For i = 2 To R1
     For s = 2 To R2
     For x = 17 To C1
     For y = 3 To C2
         If sh1.Cells(1, x) = sh2.Cells(s, 2) And sh1.Cells(i, 1) = sh2.Cells(1, y) Then
            sh2.Cells(s, y) = sh1.Cells(i, x)

     End If
     Next y
     Next x
     Next s
     Next i
　end sub

Comments

[tatsu99]

１．"情報"、”結果”シートのレイアウトの画像を提示してください
２．条件抽出の内容を（業務的な意味を）日本語で提示して下さい。及び結果をどのように格納したいのかも提示してください。
そうすれば、良い回答が得られやすくなります。

[hajihaji]

ご指摘ありがとうございました。

[tatsu99]

補足ありがとうございました。シートのレイアウトが画像でないので、回答欄に画像のサンプルを提示しておきます。（回答ではありません）

Answer 1

一度配列に入れてから処理することで速度UPが期待できます。
また、ご存じだとは思いますが処理の前後に下記をつけてもよろしいかと思います。

Application.ScreenUpdating = False

'処理
Application.ScreenUpdating = true

記事：配列を使う（Excel高速化テクニック）

http://officetanaka.net/excel/vba/speed/s11.htm

をご覧いただくとよいかと思います。

Comments

[hajihaji]

ご回答ありがとうございます。参考にさせていただきます。

Answer 2

VBAでは1行で変数宣言する場合も型宣言は省略できません。（省略するとVariant型になり速度的に不利。）

配列を使って高速化する場合のコード例
情報 も 結果 も表はA1から始まっているとする。

Sub 条件()
     '1行で書く場合、型省略不可
    Dim bk1 As Workbook, bk2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim i As Long, s As Long, x As Long, y As Long, z As Long

    Set bk1 = Workbooks("A")
    Set bk2 = Workbooks("B")

    Set sh1 = bk1.Worksheets("情報")
    Set sh2 = bk2.Worksheets("結果")
'    On Error Resume Next '動作確認ができたらコメントを外す

    Dim R1 As Long, R2 As Long, C1 As Long, C2 As Long
    R1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    R2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
    C1 = sh1.Range("A1").End(xlToRight).Column
    C2 = sh2.Range("A1").End(xlToRight).Column

    'セル範囲を配列に格納
    Dim a1(), a2()
    a1 = sh1.Range(sh1.Cells(1, 1), sh1.Cells(R1, C1)).Value
    a2 = sh2.Range(sh2.Cells(1, 1), sh2.Cells(R1, C1)).Value

    For i = 2 To R1
        For s = 2 To R2
            For x = 2 To C1
                For y = 2 To C2
                    If a1(1, x) = a2(s, 1) And a1(i, 1) = a2(1, y) Then
                        a2(s, y) = a1(i, x)
                    End If
                Next y
            Next x
        Next s
    Next i
    
    sh2.Range("A1").Resize(R2, C2).Value = a2
End Sub

上記は元コードをそのまま配列用に修正してものですが、私がコーディングするなら下記のようなコードになります。

これなら、表がA1からでなくても、.Range("A1")の部分を書き換えるだけで済みます。

Sub 条件1()
    Dim bk1 As Workbook, bk2 As Workbook
    Set bk1 = ThisWorkbook 'Workbooks("A")
    Set bk2 = ThisWorkbook 'Workbooks("B")
    
    '表範囲取得
    Dim rg1 As Range, rg2 As Range
    Set rg1 = bk1.Worksheets("情報").Range("A1").CurrentRegion
    Set rg2 = bk2.Worksheets("結果").Range("A1").CurrentRegion
'    On Error Resume Next

    Dim a1(), a2()
    a1 = rg1.Value
    a2 = rg2.Value
    
    Dim i As Long, s As Long, x As Long, y As Long, z As Long
    For i = 2 To UBound(a1, 1)
        For s = 2 To UBound(a2, 1)
            For x = 2 To UBound(a1, 2)
                For y = 2 To UBound(a2, 2)
                    If a1(1, x) = a2(s, 1) And a1(i, 1) = a2(1, y) Then
                        a2(s, y) = a1(i, x)
                    End If
                Next y
            Next x
        Next s
    Next i
    
    rg2.Value = a2
End Sub

Comments

[hajihaji]

ご教示ありがとうございます。
大変勉強になりました。
また速度も比べ物にならないぐらい速くなりました。

[hajihaji]

なんども済みません。
例えば処理をしたいリストが空白行を一行はさみブロックとしてある場合、
Range("A1").の部分を変数として処理することは可能でしょうか。
以下のようなふうに目印を起点に処理をするようにしたいのですがうまくいきません。
可能でしたらご教示のほどよろしくお願いいたします。

Sub 条件1()
Dim bk1 As Workbook, bk2 As Workbook
Set bk1 = ThisWorkbook 'Workbooks("A")
Set bk2 = ThisWorkbook 'Workbooks("B")

Dim R2 As Long
R2 = bk2.Worksheets("結果").Cells(Rows.Count, "A").End(xlUp).Row

Dim b As Long
For b = 2 To R2
Dim key As Variant

'表範囲取得
Dim rg1 As Range, rg2 As Range
Set rg1 = bk1.Worksheets("情報").Range("A1").CurrentRegion

Set key = bk2.Worksheets("結果").Cells(b, 1).Find(what:="目印").Address
Set rg2 = key.CurrentRegion
' On Error Resume Next
Dim a1(), a2()
a1 = rg1.Value
a2 = rg2.Value

Dim i As Long, s As Long, x As Long, y As Long, z As Long
For i = 2 To UBound(a1, 1)
For s = 2 To UBound(a2, 1)
For x = 2 To UBound(a1, 2)
For y = 2 To UBound(a2, 2)
If a1(1, x) = a2(s, 1) And a1(i, 1) = a2(1, y) Then
a2(s, y) = a1(i, x)
End If
Next y
Next x
Next s
Next i
Next b
rg2.Value = a2
End Sub

Answer 3

以下のような画像をを提示したいただけると、レイアウトが第三者にもよくわかると思います。
（少なくとも1行目は見出し行のように見えますが、そのようなことも提示されていません）

尚、結果シートは、実行前と実行後の両方のイメージがあればわかりやすいです。

＞総当たり表の間で条件抽出を行おうとしているのですが・・・
もっと、具体的にどのように、総当たりをするのか、どのように結果を設定するのかを書いていただけませんでしょうか。

Comments

[hajihaji]

画像の添付がうまくいかなかったので文字で起こしました。
一行目は見出しです。
B列a行＝”え”が該当しますので、a列B行でも同じ”え”を抽出するだけのものです。