Excel2010VBAの検索の高速化

質問

Excel2010VBAで、シート1のデータから変数「日時(a)」、「 データ1(a)」、「データ2(a)」、「データ3(a)」、「データ4(a)」、「データ5(a)」に格納し、変数「日時(a)」とシート2の「日時」の行に一致するセルに変数「 データ1(a)」、「データ2(a)」、「データ3(a)」、「データ4(a)」、「データ5(a)」を入力するというプログラムです。
ここで、検索を高速化する方法はあるでしょうか？（セルに関数は使用していません。）

A　　　B　　　C　　D　　　　　E　　　　　　　　　F　　　　　　
年　　　月　　日　　時刻　　日時　　　　　　　データ1　　
2011　　1　　2　　　23:01　　2011.1.2 23:01　1　　　　　　
～
～

G　　　　　H　　　　　　I　　　　　J
データ2　　データ3　データ4　データ5
2　　　　　　3　　　　　4　　　　　24
～
～

Dim a As Long
Dim 年(1 To 9999999) As Integer
Dim 月(1 To 9999999) As Integer
Dim 日(1 To 9999999) As Integer
Dim 時刻(1 To 9999999) As Date
Dim データ1(1 To 9999999)
Dim データ2(1 To 9999999)
Dim データ3(1 To 9999999)
Dim データ4(1 To 9999999)
Dim データ5(1 To 9999999) As Integer
Dim 日時(1 To 999999) As String, 範囲 As Range, 範囲文字列 As String, 縦位置 As Long

a = 1

With Workbooks("ブック.xlsm").Worksheets("シート1")

Do

日時(a) = .Cells(a + 1, 5)
データ1(a) = .Cells(a + 1, 6)
データ2(a) = .Cells(a + 1, 7)
データ3(a) = .Cells(a + 1, 8)
データ4(a) = .Cells(a + 1, 9)

If .Cells(a + 1, 10) <> "" Then
データ5(a) = .Cells(a + 1, 10)
End If

a = a + 1

Loop Until .Cells(a + 1, 1) = ""

End With

a = 1

With Workbooks("ブック.xlsm").Worksheets("シート2")

Do

Set 範囲 = .Range(Cells(2, 5), Cells(Rows.Count, 5)).Find(What:=日時(a), LookIn:=xlValues, lookat:=xlWhole)

If Not 範囲 Is Nothing Then
範囲文字列 = 範囲.Address(ReferenceStyle:=xlR1C1)
縦位置 = Mid(範囲文字列, 2, InStr(2, 範囲文字列, "C") - 2)
.Cells(縦位置, 6) = データ1(a)
.Cells(縦位置, 7) = データ2(a)
.Cells(縦位置, 8) = データ3(a)
.Cells(縦位置, 9) = データ4(a)

If データ5(a) <> 0 Then
.Cells(縦位置, 10) = データ5(a)
End If

End If

a = a + 1

Loop Until 日時(a) = ""

End With

回答よろしくお願いします。

回答No.2

ki-aaa · ベストアンサー

'シート1のデータの変数「日時(a)」は文字列であると仮定
'また、日時(a)は同じ物がないものとする
Sub xxx3()
Dim myDic As Object
Dim S1_v, S2_v
Dim i As Long, n As Long, j As Long

'With Workbooks("ブック.xlsm").Worksheets("シート1")
With Sheets("Sheet1")
j = .Range("E" & Rows.Count).End(xlUp).Row
S1_v = .Range("E1").Resize(j, 6).Value '対象範囲を配列に
End With

'With Workbooks("ブック.xlsm").Worksheets("シート2")
With Sheets("Sheet2")
j = .Range("E" & Rows.Count).End(xlUp).Row
S2_v = .Range("E1").Resize(j, 6).Value '対象範囲を配列に
End With

Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(S1_v)
myDic.Add S1_v(i, 1), i 'keyに追加、itemにi
Next i

For i = 2 To UBound(S2_v)
If myDic.exists(S2_v(i, 1)) Then
j = myDic.Item(S2_v(i, 1))
S2_v(i, 2) = S1_v(j, 2)
S2_v(i, 3) = S1_v(j, 3)
S2_v(i, 4) = S1_v(j, 4)
S2_v(i, 5) = S1_v(j, 5)
S2_v(i, 6) = S1_v(j, 6)
Else
'マッチしなかったときの処理
End If
Next

'With Workbooks("ブック.xlsm").Worksheets("シート2")
With Sheets("Sheet2")
j = .Range("E" & Rows.Count).End(xlUp).Row
.Range("E1").Resize(j, 6).Value = S2_v
End With

Set myDic = Nothing
Erase S1_v, S2_v

End Sub

お礼

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

すいませんが、このプログラムを見てもよく分からないのですが・・・。

補足

プログラムの内容はよく分からないのですが、そのままコピーさせてもらいました。
自分が作ったプログラムとは比べものにならないほど非常に高速で処理できました。

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

回答No.1

CC_T

検索の判定を見るに、データ１の日時について同日時で重複する行はないのですね？
データ２も同じく重複はない？
であれば、両データとも日時順に並べれば過去分は検索する必要もなく、
後に行くほど処理時間が短縮されるでしょう。
配列に読み込む必要すらない。
もしデータの日時はバラバラのままで残したいのであれば、別シートにコピーすればいいし。

１）両シートとも日時順にデータを並べる
２）データ２の処理行で日時を取得する
３）データ１の日時セルを上から下に見て、２で取得した日時と比較する
　２で取得した日時と一致すれば、データをシート２の各セルに記入する
４）データ記入終了、あるいはデータ１の日時が２で取得した日時を超えた場合は
　データ２の処理行を次行にし、３で検索中断したデータ１の処理行から比較を再開する。

お礼

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

日時を検索しており、その点で重複している部分は一切ありません。

<両データとも日時順に並べれば過去分は検索する必要もなく、
後に行くほど処理時間が短縮されるでしょう。

最初から日時順には並べられているのですが抜けている部分があって、それを抜けている部分はそのまま空白で、その日時のデータがある場合はそこにデータを入力するというプログラムです。
でも、日時順に並べるというのが高速化するポイントのようですね。

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