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
コード部分は、Markdown記法のタグで囲んでください。
あるいは、コード部分を選択して、<code>ボタンをクリックしてください。
https://teratail.com/help/question-tips#questionTips3-5-1
本当に###のところだけがネックなのでしょうか?
この部分をコメントアウトして時間計測してみましたか?
(どこがとは言えませんが)プログラム全体を見渡してみるとなんとなく無駄が多いような気がしています。
気がする、というだけで必要な処理なのかもしれませんが。。。
コードの修正ありがとうございました。コードだけだとやりたいことの把握が難しいので、元のデータ例、抽出後のデータも提示してもらえると、適切な回答がつきやすいと思います。
画像データですか、実データではないですよね。名前とか、携帯番号とか、、、。
メールアドレスはサンプルデータのようですが。
とりあえず ### のところのコードを私の回答の「追記2」のコードに変更して試してくれませんか。
hatena19様
データはランダムに作成されたものなので架空のものですが、一応変更しておきます。
作成してくださった「追記2」と「追記3」を試してみました。
「追記2」でも十分満足の行く速度でした!
配列を使用してのコードの書き方がいまいち分からなかったため、「追記3」を作成していただいて助かりました。
勉強していきます。
最初のコードの一番のネックは、行全体をコピーしている部分だったと思われます。
16384列のデータをコピーすることになりますからね。
回答3件
あなたの回答
tips
プレビュー