| |
'Dictionaryを使うとコードが幾らか簡単に成ります？
'でも、遅そう？
Option Explicit
Public Sub Sample2()
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim blnDirty As Boolean
Dim dicIndex As Object
Dim strProm As String
'Sheet1Listの左上隅セル位置を基準として設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'Sheet2Listの左上隅セル位置を基準として設定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
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列データを配列に取得
vntData = .Resize(lngRows, 2).Value
End With
'A、B列データをA列をKeyとしてdicIndexに登録
With dicIndex
For i = 1 To lngRows
'既に登録が無い場合
If Not .Exists(vntData(i, 1)) Then
'登録
dicIndex(vntData(i, 1)) = vntData(i, 2)
End If
Next i
End With
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 dicIndex
For i = 0 To lngRows - 1
'1行のデータを配列に取得
vntData = rngResult.Offset(i).Resize(, lngColumns).Value
'置き換えFlagをクリア
blnDirty = False
'行の先頭〜最終列まで繰り返し
For j = 1 To lngColumns
'データが""では無い場合
If vntData(1, j) <> "" Then
'Sheet1のA列から、一致するデータが有った場合
If .Exists(vntData(1, j)) Then
'データを置換
vntData(1, j) = .Item(vntData(1, j))
'置き換えFlagを立てる
blnDirty = True
End If
End If
Next j
'置き換えが有った場合
If blnDirty Then
'行データを出力
rngResult.Offset(i).Resize(, lngColumns).Value = vntData
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set dicIndex = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 07/4/15(日) 8:27 -
