| |
何か、すごーく遅そう？
以下を標準モジュールに記述してください
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim vntTable As Variant
Dim lngIndex() As Long
Dim rngResult As Range
Dim vntData As Variant
Dim vntFound As Variant
Dim blnDirty As Boolean
Dim strProm As String
'Sheet1Listの左上隅セル位置を基準として設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'Sheet2Listの左上隅セル位置を基準として設定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
With rngList
'Sheet1データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'A、B列データを配列に取得
vntTable = .Resize(lngRows, 2).Value
End With
'A、B列データをA列をKeyとして整列
ReDim lngIndex(1 To lngRows)
For i = 1 To lngRows
lngIndex(i) = i
Next i
ShellSort vntTable, lngIndex
With rngResult.Parent
'Sheet2データ行数を取得
lngRows = .UsedRange.Rows.Count
'行が無い場合
If lngRows <= 0 Then
strProm = "Sheet2にデータが有りません"
GoTo Wayout
End If
'Sheet2データ列数を取得
lngColumns = .UsedRange.Columns.Count
'列が1の場合
If lngColumns <= 0 Then
lngColumns = 2
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'Sheet2を行単位で処理
With rngResult
For i = 0 To lngRows - 1
'1行のデータを配列に取得
vntData = .Offset(i).Resize(, lngColumns).Value
'置き換えFlagをクリア
blnDirty = False
'行の先頭〜最終列まで繰り返し
For j = 1 To lngColumns
'データが""では無い場合
If vntData(1, j) <> "" Then
'Sheet1のA列から、データを探索
vntFound = BinarySearch(vntData(1, j), vntTable, lngIndex)
'一致するデータが有った場合
If vntFound <> "" Then
'データを置換
vntData(1, j) = vntFound
'置き換えFlagを立てる
blnDirty = True
End If
End If
Next j
'置き換えが有った場合
If blnDirty Then
'行データを出力
.Offset(i).Resize(, lngColumns).Value = vntData
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function BinarySearch(vntKey As Variant, _
vntScope As Variant, _
lngIndex() As Long) As Variant
' 二進探索
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
lngLow = LBound(lngIndex, 1)
lngHigh = UBound(lngIndex, 1)
Do While lngLow <= lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
Select Case vntScope(lngIndex(lngMiddle), 1)
Case Is < vntKey
lngLow = lngMiddle + 1
Case Is > vntKey
lngHigh = lngMiddle - 1
Case Is = vntKey
lngLow = lngMiddle + 1
lngHigh = lngMiddle - 1
End Select
Loop
If lngLow = lngHigh + 2 Then
BinarySearch = vntScope(lngIndex(lngMiddle), 2)
Else
BinarySearch = Empty
End If
End Function
Private Sub ShellSort(vntList As Variant, _
lngIndex() As Long, _
Optional lngKey As Long = 1)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim lngTmp As Long
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(lngIndex, 1)
lngEnd = UBound(lngIndex, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap = 0
For i = lngGap + lngTop To lngEnd
lngTmp = lngIndex(i)
For j = i To lngGap + lngTop Step -lngGap
If vntList(lngIndex(j - lngGap), lngKey) _
<= vntList(lngTmp, lngKey) Then
Exit For
End If
lngIndex(j) = lngIndex(j - lngGap)
Next j
lngIndex(j) = lngTmp
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
Hirofumi
- 07/4/15(日) 8:03 -
