[[20240722094226]]　『VBA　高速化』（よん）　ページの最後に飛ぶ

『VBA　高速化』（よん）

作業ｼｰﾄのB2から番号が入力されており、番号が一致するものをシートの5ページから14ページの中を
検索しその行を新規で追加したシートへどんどん貼り付けていくマクロです。

データ量が多いと時間がかかってしまい、時間短縮を図りたいです。
一致した行を格納し最後にまとめて貼り付け等が可能であれば高速になるのかなと思いましたが
現状の私の知識では難しく、ご教授いただけないでしょうか。
また他のところでも高速化ができる場合は教えていただきたいです。

＊一回で検索する番号件数が43件の場合、51.0625秒かかります。
多い時は150件以上になります。

Sub 一覧作成_Click()

  Dim sws, hws As Worksheet
  Dim row5, row6, row9 As Long
  Dim i, ii, matchAns As Long
  Dim txt As Long

  Application.ScreenUpdating = False

  Set sws = Sheets("作業シート")

  row5 = sws.Cells(Rows.Count, "B").End(xlUp).Row  '作業シートの最終行取得
  Worksheets.Add after:=Sheets(Worksheets.Count) '新規シート作成
  Set hws = ActiveSheet

 If row5 <> 1 Then

  For i = 2 To row5   '検索するマクロ（作業シートから順番に各シート内を検索する）

    txt = sws.Range("B" & i)  '検索番号

    For ii = 5 To 14
    On Error Resume Next

　 matchAns = 0

    Worksheets(ii).Select
      If Worksheets(ii).Cells(Rows.Count, "A").End(xlUp).Row > 1 Then  '各シートにデータがある場合処理

         row6 = Worksheets(ii).Range("A" & Rows.Count).End(xlUp).Row   '最終行取得

         matchAns = WorksheetFunction.Match(txt, Worksheets(ii).Range("W2:W" & row6), 0) '検索

     If matchAns <> 0 Then  '一致した場合
          row9 = hws.Cells(Rows.Count, "A").End(xlUp).Row  '一覧シートの最終行取得
        Worksheets(ii).Range("A" & matchAns + 1 & ":W" & matchAns + 1).Copy
        hws.Range("A" & row9 + 1 & ":W" & row9 + 1).PasteSpecial Paste:=xlPasteValues '一覧表にコピー

        Exit For  '処理終了

      Else  'ない場合は次のシートへ
      End If

      End If
      Next

        If Err.Number <> 0 Then

       Err.Number = 0  'エラー値初期化
        MsgBox txt & "の該当ありませんでした。"
     End If

  Next i

  End If

 With hws  '一覧シート
 .Select
 .Range("B:F,I:I,K:N,R:R,T:T,V:V").Delete '不要行削除
 .Range("A1").CurrentRegion.Sort key1:=.Range("B1"), Header:=xlYes  '昇順に並び替え
 .Range("A:I").EntireColumn.AutoFit
 .Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous  '罫線
 .PageSetup.Orientation = xlLandscape

 End With

 Application.ScreenUpdating = True 
End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

おはようございます＾＾
チラ見なのでなんともですが。。。
気になる点
１．エラー処理。。。他に代替案は無いか検討されるのもいいかもしれません
　　どんな時にエラーになるのか教えて戴ければうれしいです。^^;
２．仰せの通り１情報毎に書き出していては時間が掛りますので配列に格納して
　　最後に一括書込みにすれば多少はましかも
とりあえずです。
ブック巡り。。。シート巡りは多少はお時間がかかりますよね。。。
でもほっとけばエクセル様がやってくださいますので。。。(￣▽￣)
でわ
m(_ _)m

（隠居Z） 2024/07/22(月) 10:14:28

隠居Zさま

ご回答ありがとうございます。

該当する番号がどのシートにも無い時にエラーとなります。
ない場合は検索番号がメッセージボックスに表示されるだけで十分なので・・・
処理に3分以上かかることもあるので少しでも短縮していきたいです。

知識が浅く申し訳ございませんが、配列に格納するにはどうしたらいいのでしょうか。

（よん） 2024/07/22(月) 11:11:53

何も変更しないでも
エラーの表示外してログにすれば2秒ぐらいでしたよ。
10シート
範囲A1:Z200
作業シート

B2～B200まで

1～199 件検索。。。該当なし。いっぱぁ～い　(￣▽￣)
win10
excel 2016
でした。
m(__)m

実際の10シートの情報量は行列でいえばどの程度なのでしょうか

配列にしてみますね。少しお時間を。。。別案、若しくは手の速い他の回答者様
のお出ましも合わせてお待ちくださいませ。
（隠居Z） 2024/07/22(月) 11:26:56

10シートは合計で何行ぐらいあるんでしょうか。
確かにちょっと時間かかりすぎな印象です。
（xyz） 2024/07/22(月) 11:49:27

高速化出来るか分かりませんが、
オートフィルターでやってみました。
(経験上、エクセルの機能で出来ることは、
そっちを使った方が速いことが多いので）
シートのイメージが分からないので、
期待した結果にならないかも知れません。
あと、不要な列(行？）を削除するなら、
フィルターオプションを使うとより良いかと。

Option Explicit

Sub test()

    Dim wshNew As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim r As Range
    Dim vkeys As Variant

    With Worksheets
        '検索キーワード取得
        With .Item("作業シート").Range("A1").CurrentRegion
            Set r = Intersect(.Offset(1), .Columns("B"))
        End With
        vkeys = WorksheetFunction.Index(r, 0, 1)
        '結果書き込みシート用意
        Set wshNew = .Add
        k = 1
        '各シートの処理
        For i = 5 To 14
            '抽出
            With .Item(i).UsedRange
                .AutoFilter Field:=1, Criteria1:=vkeys, Operator:=xlFilterValues
                'ヒットの件数
                j = .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
                If j > 0 Then
                    k = k + j
                    .Offset(1).Copy
                    wshNew.Cells(k, 1).PasteSpecial Paste:=xlPasteValues
                End If
                .AutoFilter
            End With
        Next
    End With
End Sub

（まっつわん） 2024/07/22(月) 11:51:32

 各シード1行目がタイトル行になっている前提ですが、こんなのでもできるかもしれません

 Sub sample()
    Dim CriteriaRange As Range
    With Worksheets("作業シート")
       Set CriteriaRange = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    Worksheets.Add after:=Sheets(Worksheets.Count)
    Set hws = Worksheets(Worksheets.Count)   
    For ish = 5 To 11
        With Worksheets(ish)
           With .Range("W1", .Range("A" & Rows.Count).End(xlUp))
              .AdvancedFilter Action:=xlFilterCopy, _
                              CriteriaRange:=CriteriaRange, _
                              CopyToRange:=hws.Cells(Rows.Count, "A").End(xlUp).Offset(1), _
                              Unique:=False
           End With
        End With
    Next
    hws.Range("A:W").RemoveDuplicates Columns:=23
 End Sub
（´・ω・`） 2024/07/22(月) 13:03:06

みなさま
ご回答ありがとうございます。

情報量は平均で1600行あります。
稀に多い時は2000行を超えてきます。

エラーの表示を外してログにするというのをやったことが無いので調べてみます。

シートの情報が少なく申し訳ございませんでした。
作業ｼｰﾄのA列はブランクです。
他のシートはすべて1行目にタイトル行が入っております。

まっつわんさま

ご教授いただいたフィルターを試みたところ、該当せずでした。
ItemのRangeをB1に変更し、各シートのW列を検索するのでField:=23に
変更してみましたが、上手くいきませんでした。

　　　　　 With .Item("作業シート").Range("B1").CurrentRegion

            Set r = Intersect(.Offset(1), .Columns("B"))
　　　　　  End With

            With .Item(i).UsedRange
                .AutoFilter Field:=23, Criteria1:=vkeys, Operator:=xlFilterValues
                'ヒットの件数
                j = .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
                If j > 0 Then
                    k = k + j
                    .Offset(1).Copy
                    wshNew.Cells(k, 1).PasteSpecial Paste:=xlPasteValues
                End If

（´・ω・`）さま

Set CriteriaRange = .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))

上記のように変更し実行してみたところ、全ｼｰﾄが追加シートにコピーされてしまいます・・・。

（よん） 2024/07/22(月) 14:30:11

 > 作業ｼｰﾄのA列はブランクです。

ならば、
Set r = Intersect(.Offset(1), .Columns("B"))
の行が、
Set r = Intersect(.Offset(1), .Columns("A"))
とか、
Set r = Intersect(.Offset(1), .Columns(1))
とかかも。。。。です。
（まっつわん） 2024/07/22(月) 14:54:42

 検索値が入っているのはB列でしたね。間違いました。

 作業シートのB1セルの値と、5番目～14番目のシートのW1セルの値が同じであることを前提にした
 コードなので、それが違っているとうまくいかないです。

 こんな感じで、無理矢理やると、それはそれで問題があるかもしれません

 Sub sample()
    Dim CriteriaRange As Range
    With Worksheets("作業シート")
       Set CriteriaRange = .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))
    End With
    Worksheets.Add after:=Sheets(Worksheets.Count)
    Set hws = Worksheets(Worksheets.Count)
    Key = Worksheets("作業シート").Range("B1").Value
    For ish = 5 To 14
        With Worksheets(ish)
           tmp = .Range("W1").Value
           .Range("W1").Value = Key
           Worksheets("作業シート").Range("B1") = .Range("W1").Value
           With .Range("W1", .Range("A" & Rows.Count).End(xlUp))
              .AdvancedFilter Action:=xlFilterCopy, _
                              CriteriaRange:=CriteriaRange, _
                              CopyToRange:=hws.Cells(Rows.Count, "A").End(xlUp).Offset(1), _
                              Unique:=False
           End With
           .Range("W1").Value = tmp
        End With
    Next
    hws.Range("A:W").RemoveDuplicates Columns:=23
 End Sub
（´・ω・`） 2024/07/22(月) 15:38:09

こんばんわ。。。＾＾；
配列、やってみましたけど、やはり、3～4　秒はかかります

（´・ω・`）さん　2024/07/22(月) 15:38:09　ご案内は　瞬速です

あっという間。。。　(*^^*)ｖ

テスト代行でした。m(__)m

（隠居Z） 2024/07/22(月) 17:13:33

別路線の話が進んでいるところ恐縮ですが何点か。

■１
＞また他のところでも高速化ができる場合は教えていただきたいです。
VBAの世界では基本的にシートやセルなど（オブジェクトと言います）は、きちんと明示すれば、いちいち選択したりアクティブにしたりする必要は無く、無駄な動作になっています。
ごくわずかですがこのような部分を改善することでも高速化に寄与できると思います。

■２

  Dim sws, hws As Worksheet
  Dim row5, row6, row9 As Long
  Dim i, ii, matchAns As Long
  Dim txt As Long

↑は↓のように解釈されています。

  Dim sws As Variant, hws As Worksheet
  Dim row5 As Variant, row6 As Variant, row9 As Long
  Dim i As Variant, ii As Variant, matchAns As Long
  Dim txt As Long

気持ちはわかりますし問題が生じるものでもないですが、せっかくならば↓のようにそれぞれきちんと型を指定することをお勧めします。

  Dim sws As Worksheet, hws As Worksheet
  Dim row5 As Long, row6 As Long, row9 As Long
  Dim i As Long, ii As Long, matchAns As Long
  Dim txt As Long

以降は、最初の案通り配列を使ったらどうなるかなと私なりに考えてみた話です。

■３
＞一致した行を格納し最後にまとめて貼り付け等が可能であれば高速になるのかなと思いましたが～
今回のケースでいうと、複数のシートが相手になりますので、Rangeオブジェクトにまとめて覚えておくのはムリです。
したがって、当初の案で進めるならば

 (1) 覚えておく用の（二次元）配列を用意する
 (2) 各シートを巡回して検索値が見つかったらそのシートの各列の値を配列に格納する
 (3) 配列に格納した値を一気に書き出す

という考え方になったと思います。この時に必要となる配列の大きさは「検索値の行数 × データ列の数（+α）」で求まります。

 ※+αはシート名などを保持する場合の必要分

したがってそれぞれ

 必要行数・・・ B2セル～B列最終行までの行数

 必要列数・・・ 10+α（↓で残る列の数 + α（見つかったシート名なども表示したい場合））
                Worksheets(ii).Range("A" & matchAns + 1 & ":W" & matchAns + 1).Copy
                Range("B:F,I:I,K:N,R:R,T:T,V:V").Delete

という考え方ができます。
踏まえると、配列を作る（用意する）部分は↓のようにすればよいと思います。（無論、Redimでちゃんと定義してもよいですが）

 With Sheets("作業シート")
     最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
     二次元配列 = .Range("B2:B" & 最終行).Resize(, 11).Value
 End With

■４
ということを踏まえて私なりに考えてみたら↓のようになりました。

    Sub 配列使用例()
        Dim 最終行 As Long
        Dim 二次元配列 As Variant, 列 As Variant
        Dim 発見行 As Variant 'エラー値が受け取れるように「Variant型」にする
        Dim i As Long, ii As Long, c As Long
        Dim dstSH As Worksheet

        With Sheets("作業シート")
            最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
            If 最終行 < 2 Then
                Exit Sub
            Else
                二次元配列 = .Range("B2:B" & 最終行).Resize(, 11).Value
            End If

            For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                For ii = 5 To 14
                    最終行 = Worksheets(ii).Cells(Rows.Count, "W").End(xlUp).Row
                    If 最終行 > 1 Then
                        発見行 = Application.Match(.Cells(i, "B").Value, Worksheets(ii).Range("W2:W" & 最終行), 0)
                        If Not IsError(発見行) Then Exit For
                    End If
                Next ii

                If ii > 14 Then '最後まで見つからなかったら[ii]は15になっている
                    二次元配列(i - 1, 1) = "発見できず"
                Else
                    二次元配列(i - 1, 1) = Worksheets(ii).Name

                    c = 1
                    For Each 列 In Split("A,G,H,J,O,P,Q,S,U,W", ",")
                        c = c + 1
                        '▼配列は１からスタートしているので-1、Match関数の対象は２行目からになっているので+1が必要
                        二次元配列(i - 1, c) = Worksheets(ii).Cells(発見行 + 1, 列).Value
                    Next 列
                End If
            Next i

            Set dstSH = Workbooks.Add.Worksheets(1)
            dstSH.Range("B1").Resize(, 11).Value = Split("発見シート,A,G,H,J,O,P,Q,S,U,W", ",")
            dstSH.Range("B2").Resize(UBound(二次元配列, 1), 11) = 二次元配列
            .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy dstSH.Range("A2")
        End With
    End Sub

興味があればステップ実行等により研究してみてください。

（もこな２） 2024/07/22(月) 19:03:27

もうすでに、高速の回答がご案内済みですが　３～４秒はかかりますが。。。^^;
配列のお勉強にでもなれば幸甚です。
お約束でしたので。。。とりあえずアップしますね。m(__)m
結果が間違っておりましたら、お許しを。。。(￣▽￣；)

すみません
不備が有ったようなので修正後、後日再アップさせて戴きます
m(__)mm(__)mm(__)m
（隠居Z） 2024/07/23(火) 09:56:05

（´・ω・`）さま
ありがとうございます。
隠居Ｚさまもテスト代行ありがとうございます。
仰せの通り2秒で作業完了しました！

こちらで該当しない番号を表示させることも可能なのでしょうか？

もこな2さま

詳しいご説明ありがとうございます。

まだ詳しく内容を見れておりませんが実行してみたところ
0.38秒でした！
詳しく見てレイアウト変更等、挑戦してみます。

隠居Zさま
ありがとうございます。
ぜひ今後にも活かしていきたいのでアップをお待ちしております。

みなさま貴重なお時間ありがとうございます。

（よん） 2024/07/23(火) 10:18:59

 >こちらで該当しない番号を表示させることも可能なのでしょうか
 できないです
 結果のシートと作業シートをあらためて突合する必要があります。

 もこな２さんの案が爆速のようなので、そちらの方がよろしいかと思います。
（´・ω・`） 2024/07/23(火) 14:16:08

＞＞隠居Z） 2024/07/23(火) 09:56:05ですが
嘘ばっかり言ってました3～4秒なんて40秒ぐらいかも。。。＾＾；
自作のテストデーターが嘘っぽいので時間が出鱈目なのかもですが。

作業シートの検索番号と同じ番号は10シート通算してたくさん有るのでしょうか

通算で複数ある場合、尚且つ、1シート内でも複数ある場合は配列だけではそう簡単には
高速化出来ないかも。。。ま、私が出来ないだけかもしれませんが。
もうすこし
考えてみます。
既に配列案もご案内済みの様なので。そちらでお勉強して戴いて、こんなのはどうかな
みたいなのが出来たらアップしてみます←私のは出来ないかもしれませんので当てにせずお待
ちくださいませ。。。お騒がせして済みませんでした。m(__)m。。。^^;
<< _ _ >>
（隠居Z） 2024/07/23(火) 16:50:06

 個人的には、まっつわんさんのオートフィルタ案がわかりやすく好みです。
 365なら数式でもできそうな気がします。あるいはPower Queryでも。

 遊びで配列操作だけで書いてみました。
 動作確認は不十分です、処理速度も遅いかもしれません。

 Option Explicit

 Sub test()
    Dim app As Application
    Dim key
    Dim k As Long
    Dim m, w, v, um
    Dim ws As Worksheet
    Dim a As String, f As String

  n  Set app = Application

    key = app.Worksheets("作業シート").Columns(2).SpecialCells(xlCellTypeConstants).Value
    key(1, 1) = "key"

    For k = 5 To 14
        Set ws = Worksheets(k)
        f = f & ",'" & ws.Name & "'!" & ws.Cells(1).CurrentRegion.Address
    Next
    f = "vstack(" & Mid(f, 2) & ")"
    w = Evaluate(f)
    v = app.Index(w, 0, 23)
    m = app.IsNumber(app.XMatch(v, key))
    m(1, 1) = True

    w = app.Filter(w, m)
    w = app.Index(w, Evaluate("row(1:" & UBound(w) & ")"), _
        Array(1, 7, 8, 10, 15, 16, 17, 19, 21, 23))     '残す列番号

    Worksheets.Add(after:=Worksheets(Worksheets.Count)) _
        .Cells(1).Resize(UBound(w, 1), UBound(w, 2)).Value = w

    key(1, 1) = "該当なし"
    um = app.IsError(app.XMatch(key, v))
    w = app.Transpose(app.Filter(key, um))
    If UBound(w) > 1 Then MsgBox Join(w, vbLf)

 End Sub
（マナ） 2024/07/23(火) 19:26:31

<Sheet1>(検索キーワード＆検索結果用)

	No.		No.	項目1	項目4	項目3	項目6
	20240702						
	20240708						
	20240709						
	20240715						
	20240722						
	20240801						
	20240810

<Sheet2>（検索元データ1）

	日付	   項目1	項目2	項目3	項目4	項目5	項目6	No.
	2024/7/1	1	2	3	4	5	6	20240701
	2024/7/2	2	2	3	4	5	6	20240702
	2024/7/3	3	2	3	4	5	6	20240703
	2024/7/4	4	2	3	4	5	6	20240704
	2024/7/5	5	2	3	4	5	6	20240705
	2024/7/6	6	2	3	4	5	6	20240706
	2024/7/7	7	2	3	4	5	6	20240707
	2024/7/8	8	2	3	4	5	6	20240708
	2024/7/9	9	2	3	4	5	6	20240709
	2024/7/10	10	2	3	4	5	6	20240710

<Sheet3>（検索元データ2）

	日付	項目1	項目2	項目3	項目4	項目5	項目6	No.
	2024/7/15	11	12	13	14	15	16	20240715
	2024/7/16	11	12	13	14	15	16	20240716
	2024/7/17	11	12	13	14	15	16	20240717
	2024/7/18	11	12	13	14	15	16	20240718
	2024/7/19	11	12	13	14	15	16	20240719
	2024/7/20	11	12	13	14	15	16	20240720
	2024/7/21	11	12	13	14	15	16	20240721
	2024/7/22	11	12	13	14	15	16	20240722
	2024/7/23	11	12	13	14	15	16	20240723
	2024/7/24	11	12	13	14	15	16	20240724

<Sheet4>（一時データ抽出用）

	No.	項目1	項目4	項目3	項目6

＜＜コード＞＞
Option Explicit

Sub test()

    '検索するシート群
    Dim shsBase As Sheets: Set shsBase = Sheets(Array("Sheet2", "Sheet3"))
    '検索欄
    Dim rngCriteria As Range: Set rngCriteria = Worksheets("Sheet1").Range("A1").CurrentRegion
    '一時抽出セル範囲
    Dim rngCopyTo As Range: Set rngCopyTo = Worksheets("Sheet4").Range("A1:E1")
    '結果出力範囲
    Dim rngResults As Range: Set rngResults = rngCriteria.Offset(, 2).Resize(, rngCopyTo.Columns.Count)
    Dim sht As Variant  '各シート

    '各シートから抽出
    rngResults.CurrentRegion.Offset(1).ClearContents
    For Each sht In shsBase
        sht.UsedRange.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
        With rngCopyTo.CurrentRegion
            If .Rows.Count > 1 Then
                .Offset(1).Copy rngCriteria.Cells(rngCriteria.Rows.Count, 3).End(xlUp).Offset(1)
            End If
        End With
    Next

    '結果出力欄整理(ヒットなしは空欄）
    rngCriteria.Copy rngResults.Cells(rngResults.Rows.Count + 1, 1)
    With rngResults.Resize(rngResults.Rows.Count * 2)
        .RemoveDuplicates Columns:=1, Header:=xlNo
        .Sort key1:=.Cells(1), order1:=xlAscending, Header:=xlYes
    End With
End Sub

＜＜コード終わり＞＞

コード実行結果
<Sheet1>

	No.		No.	項目1	項目4	項目3	項目6
	20240702		20240702	2	4	3	6
	20240708		20240708	8	4	3	6
	20240709		20240709	9	4	3	6
	20240715		20240715	11	14	13	16
	20240722		20240722	11	14	13	16
	20240801		20240801				
	20240810		20240810

（まっつわん） 2024/07/24(水) 11:11:07

編集中に送信してしまったけど、
こういうことがしたいってことかな。。。。？
（まっつわん） 2024/07/24(水) 11:13:50

隠居Zさま
＞作業シートの検索番号と同じ番号は10シート通算してたくさん有るのでしょうか
→10シートの中で1つしかありません。

マナさま
ご回答ありがとうございます。
勉強させていただきます。

まっつわんさま

Sheet1にはB列の検索番号のみ入力しています。
検索した結果が新しく追加する別シートに転記されるようにしたいです。
検索する番号は連番とはなっておらず、123456、132456、124356等、順番はバラバラになります。
送っていただいたコードを勉強します。

（よん） 2024/07/24(水) 14:09:43

情報のご提供、ありがとうございます。＾＾
わたしも、勉強致します。。。。勘案中。。。

　　↑　途中で訳が分からなくなっています。。。^^;
マナ先生のvstack,filter　便利そうですね。。。
何時もながら、頭が下がります。

めざそう。高速化

m(__)m
（隠居Z） 2024/07/24(水) 15:02:51

 >検索した結果が新しく追加する別シートに転記されるようにしたいです。

まずは、提示した内容で、
練習してみてはいかがでしょう？

理解できれば応用すればいいかと。。。

（まっつわん） 2024/07/25(木) 09:34:36

ありがとうございます。

sheet1にはメモ等が記載されていますので、
理解し応用できるようにやってみます！
また躓いたら質問させてください。
（よん） 2024/07/25(木) 10:10:15

もこな2さま

教えていただいたコードについて教えてください。
作業ｼｰﾄの二次元配列を格納し、発見できなかった場合、
結果は作業ｼｰﾄに入力されている値が反映されますが、

＞二次元配列(i - 1, 2) = "発見できず"

これ以降の列の値を空白にしたく、

二次元配列(i - 1, 3).Resize(, 10) = ""

というコードをいれてみましたが、オブジェクトが必要です。
とエラーになりました。

二次元配列(i - 1, 3)＝""
二次元配列(i - 1, 4)＝""

のように一つ一つ行う必要がありますか？

（よん） 2024/07/25(木) 11:53:54

■５
＞～一つ一つ行う必要がありますか？
それでも解決するとおもいますが、↓は箱（入れ物）が欲しいだけなので

 二次元配列 = .Range("B2:B" & 最終行).Resize(, 11).Value

↓のように""を格納するようにしたほうが手っ取り早いとおもいます。（書き換えをする分だけ処理に無駄が出ますし）

    Sub 配列使用例_改()
        Dim 最終行 As Long
        Dim 二次元配列 As Variant, 列 As Variant
        Dim 発見行 As Variant
        Dim i As Long, ii As Long, c As Long
        Dim dstSH As Worksheet
        With Sheets("作業シート")
            最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
            If 最終行 < 2 Then
                Exit Sub
            Else
                Set dstSH = Workbooks.Add.Worksheets(1) 'ここに移動
                二次元配列 = dstSH.Range("B2:B" & 最終行).Resize(, 11).Value '対象シートを変更
            End If

            For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                For ii = 5 To 14
                    最終行 = Worksheets(ii).Cells(Rows.Count, "W").End(xlUp).Row
                    If 最終行 > 1 Then
                        発見行 = Application.Match(.Cells(i, "B").Value, Worksheets(ii).Range("W2:W" & 最終行), 0)
                        If Not IsError(発見行) Then Exit For
                    End If
                Next ii

                If ii > 14 Then
                    二次元配列(i - 1, 1) = "発見できず"
                Else
                    二次元配列(i - 1, 1) = Worksheets(ii).Name
                    c = 1
                    For Each 列 In Split("A,G,H,J,O,P,Q,S,U,W", ",")
                        c = c + 1
                        二次元配列(i - 1, c) = Worksheets(ii).Cells(発見行 + 1, 列).Value
                    Next 列
                End If
            Next i

            dstSH.Range("B1").Resize(, 11).Value = Split("発見シート,A,G,H,J,O,P,Q,S,U,W", ",")
            dstSH.Range("B2").Resize(UBound(二次元配列, 1), 11) = 二次元配列
            .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy dstSH.Range("A2")
        End With
    End Sub

◼️余談
たぶんですが、私の案が早くみえるのは、別ブックに出力しているからじゃないでしょうか？
データがあるブックに再計算に時間がかかる揮発性関数を使った数式が無いか、何らかのイベントが実行されていないか等チェックされたほうがよいとおもいます。

（もこな２） 2024/07/25(木) 12:39:11

なるほど！格納するのは作業ｼｰﾄではなく、新たに追加したシートでも良いのですね！
元のブックに戻る必要がありましたので下記の通りにやってみました。

Sub 配列使用例()

        Dim 最終行 As Long
        Dim 二次元配列 As Variant, 列 As Variant
        Dim 発見行 As Variant
        Dim i As Long, ii As Long, c As Long
        Dim dstSH As Worksheet
        Dim bk As Workbook
        Set bk = ActiveWorkbook

        With Sheets("作業シート")
            最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
            If 最終行 < 2 Then
                Exit Sub
            Else
                Set dstSH = Workbooks.Add.Worksheets(1) 'ここに移動
                二次元配列 = dstSH.Range("B2:B" & 最終行).Resize(, 11).Value '対象シートを変更
            End If
            bk.Activate
            For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                For ii = 5 To 14
                    最終行 = Worksheets(ii).Cells(Rows.Count, "W").End(xlUp).Row
                    If 最終行 > 1 Then
                        発見行 = Application.Match(.Cells(i, "B").Value, Worksheets(ii).Range("W2:W" & 最終行), 0)
                        If Not IsError(発見行) Then Exit For
                    End If
                Next ii
                If ii > 14 Then
                    二次元配列(i - 1, 1) = "発見できず"
                Else
                    二次元配列(i - 1, 1) = Worksheets(ii).Name
                    c = 1
                    For Each 列 In Split("A,G,H,J,O,P,Q,S,U,W", ",")
                        c = c + 1
                        二次元配列(i - 1, c) = Worksheets(ii).Cells(発見行 + 1, 列).Value
                    Next 列
                End If
            Next i

            dstSH.Range("B1").Resize(, 11).Value = Split("発見シート,A,G,H,J,O,P,Q,S,U,W", ",")
            dstSH.Range("B2").Resize(UBound(二次元配列, 1), 11) = 二次元配列
            .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy dstSH.Range("A2")

        End With

    End Sub

余談についてですが、このブックにはシート数が多いのと、
このほかにもマクロが登録されていますのでその影響もあるのかなと考えています。
別ブックに作成した方が都合がよかったのでこのまま活用させていただきたいと思います。
他のところも一つずつチェックしていきます。
（よん） 2024/07/25(木) 14:11:18

おはようございます。＾＾
もうすでに、解決済みかもしれませんが。。。やっとできました。研究発表でぇ～す。

前程
作業シートは　B1　は項目名ではなく、ここから検索ナンバーが
入力されているものとしています。

私の恐怖と推測のテスト情報で実行致しますと。1秒ちょいくらい？...^^;　でした
実際の情報では遅くなるかもしれません。
一部、マナ先生のコードからのパクリもあります。(*^^*)。。。m(__)m
結果は合ってるかどうかわかりません。(￣▽￣；)
でわ

 Option Explicit
Sub OneInstance_A()
    Dim ws            As Worksheet
    Dim i             As Long
    Dim sTx           As String
    Dim app           As Object
    Dim an            As Long
    Dim ln            As Long
    Dim x             As Variant
    Dim w()           As Variant
    Dim wk()          As Variant
    Dim snum()        As Variant
    Dim ans()         As Variant
    Dim log()         As Variant
    Dim md()          As Variant
    Dim at            As Double
    at = Timer
    Rem wS_DeleteB
    Set app = Application
    For i = 5 To 14
        Set ws = Worksheets(i)
        sTx = sTx & ",'" & ws.Name & "'!" & ws.Cells(1).CurrentRegion.Address
    Next
    sTx = "vstack(" & Mid(sTx, 2) & ")"
    w = Evaluate(sTx)
    wk = app.Index(w, 0, 23)
    snum = Worksheets("作業シート").Cells(1, 2).CurrentRegion.Value
    For i = LBound(snum, 1) To UBound(snum, 1)
        x = app.Match(snum(i, 1), wk, 0)
        If IsError(x) Then
            ReDim Preserve log(ln)
            log(ln) = snum(i, 1)
            ln = ln + 1
        Else
            ReDim Preserve ans(an)
            Rem 1 7 8 10  15  16  17  19  21  23
            ans(an) = Array(w(x, 1), w(x, 7), w(x, 8), w(x, 10), _
                            w(x, 15), w(x, 16), w(x, 17), w(x, 19), _
                            w(x, 21), w(x, 23))
           an = an + 1
        End If
    Next
    For i = 1 To 2
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = _
                       Array("441BEB6D-EC9D-4930-B1FF-1Result", _
                             "0645C360-6AC9-49D2-9E70-5E6CLOG")(i - 1)
    Next
    With Worksheets(5)
        md = app.Filter(.Range("A1:W1"), Array(1, 0, 0, 0, 0, 0, 1, 1, 0, 1, _
                                               0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1))
    End With
    With Worksheets("441BEB6D-EC9D-4930-B1FF-1Result")
        .Cells(1).Resize(, UBound(md)) = md
        .Cells(2, 1).Resize(UBound(ans) + 1, UBound(ans(0)) + 1) = app.Index(ans, 0, 0)
    End With
    With Worksheets("0645C360-6AC9-49D2-9E70-5E6CLOG")
        .Cells(1).Resize(UBound(log) + 1) = app.Transpose(log)
    End With
    Erase w, wk, snum, ans, log, md
    MsgBox "終了" & Format(Int(Timer - at) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - at) - Int(Timer - at), ".000") & " 秒"
End Sub
（隠居Z） 2024/07/26(金) 08:33:52

隠居Zさま

ありがとうございます。
今回はもこな2さまより教えていただいたコードを活用させていただきますが、
今後に活かすため勉強させていただきます。

（よん） 2024/07/26(金) 09:03:09

恐縮で御座います。。。m(__)m
たのしく、勉強させて戴きました。有難う御座いました。
（隠居Z） 2024/07/26(金) 09:29:04

 各シートのデータ量がどの程度か不明ですが、こんな方法も

 Sub test()
     Dim myList, s(1), i&
     myList = Filter(Sheets("作業シート").[transpose(if(b2:b1000<>"",b2:b1000))], False, 0)
     s(0) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=No';"
     For i = 5 To 14
         s(1) = s(1) & " Union All Select * From `" & Sheets(i).Name & "$A2:W` Where F23 In (" & Join(myList, ",") & ")"
     Next
     With CreateObject("ADODB.Recordset")
         .Open Mid$(s(1), 11), s(0)
         Sheets.Add(, Sheets("作業シート")).Cells(2, 1).CopyFromRecordset .DataSource
     End With
 End Sub
（jindon） 2024/08/20(火) 11:12:46

コメント返信：

[ 一覧(最新更新順) ]

[[20240722094226]] 『VBA 高速化』（よん） ページの最後に飛ぶ

[[20240722094226]]　『VBA　高速化』（よん）　ページの最後に飛ぶ