質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.79%

別々のシートからセル範囲をコピーして、一旦配列に格納。格納したデータを一つのシートへ一括で貼り付けしたい。

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 2
  • VIEW 1,903

sadaharu

score 13

イメージ説明
イメージ説明

VBAにて高速処理ができないか悩んでいます。

処理内容は
1.検索ワードを入力 
検索ワードは同じ行の場合はAND条件、
異なる行の場合はOR条件です。
画像では「ぶっかけ AND 九州」 or「ハヤシライス」となります。
2.日付ごとに並んだシート(リストが作成されている)を検索し、条件に合致する行(2行で1項目)をコピー
3.検索ワードが入力されているシートに検索結果を貼り付けする
処理を行っています。

一番上の画像が検索結果を表示するシート、二番目の画像がデータイメージです。

プログラム自体は作動しますが、各シートごとに検索結果をコピーし、都度貼り付けをしている(ソースコードを##################で囲んだ部分です。)ため、処理に時間がかかっています。

実際、#####で囲んだ部分をコメントアウトして実行すると処理速度が劇的に速くなります。
(通常は40秒かかり、#######で囲んだ部分をコメントアウトして実行した場合は、5秒で処理が終了しました。
1シート当り:約20件のデータ
シート数:400シート
170件ヒットした場合です。)

そのため、配列に格納するすれば高速処理が可能になるのではと思い、考えましたがどうすればよいのかわかりません。

アドバイスください。

Sub 検索用()

Application.ScreenUpdating = False
With ThisWorkbook.Sheets("検索")
Dim i As Long


'検索結果始まりタイトル行
Dim kiten As Range
Set kiten = .Range("A14")

'以前の検索結果を削除
kiten.CurrentRegion.UnMerge
kiten.CurrentRegion.Offset(1).Interior.ColorIndex = xlNone
kiten.CurrentRegion.Offset(1).ClearComments
kiten.CurrentRegion.Offset(1).ClearContents


'検索候補が1行だった場合、配列ubound lboundがエラーとなるため
'2行にする措置
Dim flag As Boolean
If .Cells(5, "C").Value = "" Then
.Cells(5, "C").Value = "................"
flag = True
End If

'検索シートの右側が検索対象
Dim j As Long
Dim arrayShname() As String
Dim sh As Variant
ReDim arrayShname(0)
For Each sh In ThisWorkbook.Sheets
If sh.Index > .Index Then
ReDim Preserve arrayShname(j)
arrayShname(j) = sh.Name
j = j + 1
End If
Next

End With


Dim key As Variant
Dim bkey As Variant
'検索ワードを配列へ格納
key = ThisWorkbook.Sheets("検索").Range("C4").CurrentRegion.Value

'検索ワード空白だったら終了
If IsEmpty(key) Then
Exit Sub
End If

''検索結果始まり行
Dim k As Long
k = 15

'bによりkeyの一次元配列数(検索行数)をカウント=検索行ごとに検索していく
Dim b As Long
For b = LBound(key, 1) To UBound(key, 1)

bkey = Split(Replace(Application.WorksheetFunction.Trim(key(b, 1)), " ", " "), " ")

'シート配列から検索していく
Dim p As Long
For p = 0 To j - 1

Dim iii As Long
Dim tmpSheet As Worksheet
Dim endRow As Long

Set tmpSheet = ThisWorkbook.Sheets(arrayShname(p))
endRow = tmpSheet.Cells(Rows.Count, "V").End(xlUp).Row


For i = 7 To endRow Step 2
   Dim HHH As Integer
   Dim c As Range

    With tmpSheet.Rows(i & ":" & i + 1)

          For HHH = LBound(bkey) To UBound(bkey)
           Set c = .Find(What:=bkey(HHH), matchbyte:=False, _
                       LookIn:=xlValues, LookAt:=xlPart)   '---(1)

        '条件に当てはまるセルがあるかどうかを判定
        If c Is Nothing Then

     GoTo TTT
        End If

        Next HHH
           '繰返し検索し、条件を満たす行を検索する


'########################  この部分の処理で時間がかかっている          
tmpSheet.Rows(i & ":" & i + 1).Copy _
ThisWorkbook.Sheets("検索").Rows(k)
'#########################


k = k + 2        
End With
TTT:

    Next i
    Next p
Next b

If flag Then
ThisWorkbook.Sheets("検索").Cells(5, "C").ClearContents
End If

Application.ScreenUpdating = True
End Sub
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • hatena19

    2019/06/01 20:47

    とりあえず ### のところのコードを私の回答の「追記2」のコードに変更して試してくれませんか。

    キャンセル

  • sadaharu

    2019/06/01 21:01

    hatena19様

    データはランダムに作成されたものなので架空のものですが、一応変更しておきます。

    作成してくださった「追記2」と「追記3」を試してみました。
    「追記2」でも十分満足の行く速度でした!
    配列を使用してのコードの書き方がいまいち分からなかったため、「追記3」を作成していただいて助かりました。
    勉強していきます。

    キャンセル

  • hatena19

    2019/06/01 21:09

    最初のコードの一番のネックは、行全体をコピーしている部分だったと思われます。
    16384列のデータをコピーすることになりますからね。

    キャンセル

回答 3

checkベストアンサー

+2

時間がかかるのは、###のところがネックというより、
Findで検索して、1データずつ処理していることだと思います。
Find自体、重い処理です。

配列を使って高速化することはできますが、全面的にコードを書き直す必要があります。

そのまえに、やることはいろいろあります。
Findはやめて、AutoFilter で絞り込んだ結果をコピーするというロジックに書きなおすと、
かなり改善できると思います。

追記1

2行で1項目ということなので、AutoFilter を使うなら、作業列を使う方法になるかな。

  1. 作業列の奇数行に、条件に一致するなら、〇 を出力する式を設定。
  2. 偶数行は、上の列を参照する式にする。
  3. AutoFilter で作業列の〇の行を絞り込む。
  4. これの作業列を除いた列をコピーする。
  5. 作業列をクリアする。

これで、コピーは1回ですむのでかなり高速化はできると思います。

配列を使う場合は、
セルをひとつづつ参照するのが時間がかかるので、セルへのアクセスをなるべく減らす。
配列上で処理をして、結果を一気にレンジに代入する。
という方針で作成すると高速化できます。

  1. 検索対象範囲を一気に配列に格納する。
  2. 配列をループして条件に一致する行と次の行を結果配列に追加していく。
  3. 結果配列をレンジに代入する。

追記2

実際、#####で囲んだ部分をコメントアウトして実行すると処理速度が劇的に速くなります。
(通常は40秒かかり、#######で囲んだ部分をコメントアウトして実行した場合は、5秒で処理が終了)

質問に上記が追記れさているのに気が付きました。
コピーが値だけでいいなら(書式は無視)、Value の代入にすると改善されるかも。

ThisWorkbook.Sheets("検索").Range("A" & k).Resize(2,23).Value _
    = tmpSheet.Range("A" & i).Resize(2,23).Value


アップされた画像をみるとひとつのデータ範囲は、2行×23列のようですので、それに合わせて変更しました。

追記3

追記1 の後者の配列を使う場合のロジックのコード例

検索範囲固定、キーワード固定、検索列1行目 のシンプルなモデルでのコード例ですので、
ロジックを理解して、実際のものに応用してください。

Public Sub test()
    Dim f() As Variant
    f = Worksheets(1).Range("A1").Resize(100, 5).Value '検索範囲を配列に格納

    Dim r() As Variant
    ReDim r(1 To UBound(f), 1 To UBound(f, 2)) '検索結果格納用配列


    Dim KeyWord As String
    KeyWord = "xxx" '検索キーワード

    Dim i As Long, rcnt As Long, j As Long
    rcnt = 0

    For i = 1 To UBound(f) Step 2
        If InStr(f(i, 1), KeyWord) > 0 Then '部分一致したら
            '検索結果配列に格納
            For j = 0 To 1 '2行分
                rcnt = rcnt + 1
                r(rcnt, 1) = f(i + j, 1)
                r(rcnt, 2) = f(i + j, 2)
                r(rcnt, 3) = f(i + j, 3)
                r(rcnt, 4) = f(i + j, 4)
                r(rcnt, 5) = f(i + j, 5)
            Next
        End If
    Next

    Worksheets(2).Range("A1").Resize(rcnt, 5).Value = r '検索結果配列をセル範囲に代入

End Sub

処理のネックとなるセルへのアクセスは、検索範囲を配列に格納と、検索結果配列の代入の2回だけで、
あとは、メモリ上の操作になりますので、高速化します。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/05/30 21:49

    hatena19さん

    Findの検索がネックで、配列で高速化する前に、ソートやフィルターなどの改善策もあると直感しましたが、うまく表現できませんでした。
    私が漠然と感じたことを具体的に表現した回答をされており、大変感服いたしました。

    キャンセル

  • 2019/05/31 06:48

    hatena19様 アドバイスありがとうございます。
    当初はAutofilterでの絞り込みを考えましたが、リストが「2行で1項目」で構成されており、Autofilterや並び替え等の機能を使用することができません。
    いわば、リストとしての体裁が整っていないシートから検索をせざるを得ない状況です。

    そのため、現在のコードのようにFindを使用し、検索範囲をリストの2行ごとに区切り、都度検索をしていく方法を取りました。

    目的は高速化したいだけなので、配列にこだわっているわけではありません。
    無駄の多い見づらいコードを掲載して申し訳ありませんが、なにかアイデアをいただけると助かります。

    キャンセル

  • 2019/05/31 10:32

    チェックするセルの列(カラム)位置やセルの属性が固定なら、
    Findを使うより自前でセルの値を比較していったほうが速い
    ような気がしますが、それらは固定ではないのでしょうか?

    キャンセル

+2

Sub test()
    Dim wsSEarch As Worksheet: Set wsSEarch = ThisWorkbook.Worksheets("検索")
    Dim rngToSearch As Range: Set rngToSearch = wsSEarch.Range("C4").CurrentRegion
    Dim rngForSearch As Range
    Dim rngTarget As Range
    Dim rngFind As Range
    Dim c As Range
    Dim c2 As Range
    Dim ws As Worksheet
    Dim ss As Variant
    Dim s As Variant
    Dim ixRow As Long
    Dim ixMax As Long
    Dim ixResult As Long
    Dim i As Long
    Dim flg As Boolean

    If IsEmpty(rngToSearch(1).Value) Then Exit Sub
    rngToSearch.Replace " ", " "

    For Each c In rngToSearch
        For Each ws In ThisWorkbook.Worksheets
            If ws.Index > wsSEarch.Index Then
                ixRow = 1
                Set rngForSearch = ws.UsedRange
                ixMax = rngForSearch.Rows.Count

                Do Until ixRow > ixMax
                    ss = Split(c.Value, " ")
                    Set rngTarget = rngForSearch.Find(s(0), rngForSearch(rngForSearch.Cells.Count), , xlPart)
                    If rngTarget Is Nothing Then Exit Do
                    Set rngTarget = Application.Range(rngForSearch.Rows(Int(rngTarget.Row) / 2) * 2, rngForSearch.Rows(ixMax))

                    For Each s In ss
                        flg = False
                        For Each c2 In rngTarget
                            If InStr(1, c2.Value, s) > 0 Then
                                flg = True
                                Exit For
                            End If
                        Next
                        If flg = False Then Exit For
                    Next

                    If flg Then
                        rngTarget.Copy wsSEarch.Cells(ixResult, 1)
                        ixResult = ixResult + 2
                        ixRow = ixRow + 2
                        Set rngForSearch = Application.Range(rngForSearch.Rows(ixRow), rngForSearch.Rows(ixMax))
                    End If
                Loop

            End If
        Next
    Next
End Sub


行き当たりばったりで書きました。
配列とか配列変数とかは出来る限り使ってません。
まずはロジック(?)の整理かと思いましたので。。。
コンパイルはしましたが動作確認はしてません。
コピペで時間が掛かるなら、コピペの回数を減らす方向で考え直したいと思います。

1シート当り何件くらいデータがあって、
何個シートがあって、
何件ヒットしたときに40秒かかるのですか?

あと、配列がどうのという前に、
1行に1件のデータという風に整形したほうが検索しやすいかもですね。
元のデーター数が多くて、ヒットするデータ数も多いなら、
エクセルで処理するのはもしかして辛いのかなぁ。。。。

参考になれば。。。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/06/01 20:04

    mattuwan様 
    サンプルコードの作成ありがとうございます!
    ここまできれいなコードを書くことができるのですね。

    そのままコピペして実行しようとしましたが、
    「Set rngTarget = rngForSearch.Find(s(0), rngForSearch(rngForSearch.Cells.Count), , xlPart)」や
    「Set rngTarget = Application.Range(rngForSearch.Rows(Int(rngTarget.Row) / 2) * 2, rngForSearch.Rows(ixMax))」
    付近でエラーになってしまいました。

    レベルが違いすぎて、よく理解しきれていませんが、正常に動作するようにやってみたいと思います。

    ちなみに、処理に40秒かかるのは、
    1シート当り:約20件のデータ
    シート数:400シート
    170件ヒットした場合です。

    キャンセル

  • 2019/06/01 22:37 編集

    画像見ましたが、2行で1件は必須でしょうか?
    エクセル的には1行1件の方が処理しやすい(コードが簡単になる)ので、
    中間処理として1行1件に整形した方がよいように思います。
    また、データ数も少ない(20件×400個=8000件)ので、
    1つのシートに纏めた方が作業はやりやすいし、コードのメンテナンスも後々楽かなぁという印象です。
    いずれにしても、各作業をサブルーチンに追い出すと考える方も楽ですし、
    コードのメンテナンスも楽かとは思います。

    あと、検索語もすべてOr条件なのですね?
    (あれか、それか、これかのいずれかに該当すればHitとする)
    その辺の条件も日本語で明確に説明された方がよいかと思います。
    (他人が書いたコードを読むのは流儀がそれぞれあり結構困難な作業なので。。。)

    あと、不要な空白行はスクロールを強要し作業効率が悪いかと思いました。
    作業ブロックの分けを表現する程度にした方が、個人的に好みです。
    インデントも含めて、1年後の自分が読めるような書き方を覚えてください。

    エクセル的には、
    フィルターオプションという機能を使えるように、
    データを整形したら、
    検索(抽出)部分のコードが恐ろしく簡便になりますので、
    そちらの機能を使えるようになられるといいかと思います。
    いずれにしても工夫次第でどうにでもなるのはなるのですが。。。

    高速化については、
    ループの回数を減らす(出来ればVBAでループ処理を書かずにエクセルに任せる)、
    対象のセル範囲を必要最小限にする、
    に注意すれば、配列変数に一旦データを書き出すより速い場合もあります。
    (フィルタオプションは意外と遅かったですが^^;何より遅いかは忘れましたが^^;;)
    あと、一般的に個々のセルの読み書きは以外と時間が掛かります、
    そういう場合は、配列変数を使うなどしてセルの読み書きの回数を減らすと劇的に処理速度が改善するかと思います。

    キャンセル

  • 2019/06/01 22:44

    ああ、コードの方はエラーが出たようでごめんなさいです。
    テストデータをつくるのが億劫なので(前提条件も解り難かったし)、ちょっとデバッグする元気はありません。すみません。
    こちらが、時間があればいいのですが、ちょっと難しいです。
    気が向けば、気分転換に再チャレンジするかも知れませんが、期待はしないでください。

    キャンセル

  • 2019/06/02 08:23

    mattuwan様

    >画像見ましたが、2行で1件は必須でしょうか?
    必須です。
    確かに1行1件がメンテナンスも容易なのは重々認識しているのですが、他の人間も共同で使っており、
    2行で1件でしか折り合いがつかない状況なのです。

    >あと、検索語もすべてOr条件なのですね?
    >(あれか、それか、これかのいずれかに該当すればHitとする)
    検索語は同じ行の場合はAND条件、
    異なる行の場合はOR条件です。
    画像では「ぶっかけ AND 九州」 or「ハヤシライス」となります。


    >あと、不要な空白行はスクロールを強要し作業効率が悪いかと思いました。
    >作業ブロックの分けを表現する程度にした方が、個人的に好みです。
    >インデントも含めて、1年後の自分が読めるような書き方を覚えてください。

    その他いろいろと改善のアドバイスありがとうございます。
    万人にとって見やすいコードを作成していくようにしていきたいと思います。

    キャンセル

0

手っ取り早く対応を方針に、現状ネックになっているところだけをどうにか改善できないかいくつか試してみました。
1000回コピーするという処理の時間計測です。
結論としては現状行全体をコピーしてるのをやめて、列数を限定すると大幅に改善しました。
配列を使うのは逆に遅くなりました(やり方が悪い?)

    Debug.Print "現状"
    k = 1
    Debug.Print Now()
    For n = 1 To 1000
        tmpSheet.Rows(i & ":" & i + 1).Copy _
        ThisWorkbook.Sheets("検索").Rows(k)
    Next
    Debug.Print Now()
    DoEvents

    Debug.Print "配列使用"
    k = 3
    Debug.Print Now()
    For n = 1 To 1000
        tmp = tmpSheet.Rows(i & ":" & i + 1)
        ThisWorkbook.Sheets("検索").Rows(k & ":" & k + 1) = tmp
    Next
    Debug.Print Now()
    DoEvents

    Debug.Print "値だけコピペ"
    k = 5
    Debug.Print Now()
    For n = 1 To 1000
        tmpSheet.Rows(i & ":" & i + 1).Copy
        ThisWorkbook.Sheets("検索").Rows(k).PasteSpecial xlPasteValues
    Next
    Debug.Print Now()
    DoEvents

    Debug.Print "列数を限定&値だけコピペ"
    k = 7
    Debug.Print Now()
    For n = 1 To 1000
        tmpSheet.Range("A" & i & ":Z" & i + 1).Copy
        ThisWorkbook.Sheets("検索").Cells(k, 1).PasteSpecial xlPasteValues
    Next
    Debug.Print Now()
    DoEvents

現状
2019/05/31 10:52:23 
2019/05/31 10:52:30 
配列使用
2019/05/31 10:52:31 
2019/05/31 10:52:47 
値だけコピペ
2019/05/31 10:52:47 
2019/05/31 10:52:52 
列数を限定&値だけコピペ
2019/05/31 10:52:52 
2019/05/31 10:52:54 

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/05/31 16:44

    高速化の手段としては、1000件の検索結果をコピーする場合、copyメソッドだと1000回実行する必要がありますが、配列を使用して1回で済ますという方法があるということを言いたかったのですが。

    キャンセル

  • 2019/05/31 16:48

    回答にも書いていますが、あくまでも現状ネックになっている部分(#####のところ)だけを修正していかに改善できるかを調査したものです。
    (大規模改造は質問者さまが望んでいないようですので)

    キャンセル

  • 2019/05/31 16:52

    そういうことなら了解です。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.79%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • トップ
  • VBAに関する質問
  • 別々のシートからセル範囲をコピーして、一旦配列に格納。格納したデータを一つのシートへ一括で貼り付けしたい。