| |
こんなのでは？
「FILEA（SHEET1）」、「FILEB（SHEET1）」共に列見出しが在る物とします
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList1 As Range
Dim rngList2 As Range
Dim rngResult As Range
Dim vntKeys As Variant
Dim vntItems As Variant
Dim dicIndex As Object
Dim strProm As String
'「FILEA（SHEET1）」の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList1 = Workbooks("FILEA.xls").Worksheets("Sheet1").Range("A1")
'「FILEB（SHEET1）」の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList2 = Workbooks("FILEB.xls").Worksheets("Sheet1").Range("A1")
'「FILEA（SHEET2）」の先頭セル位置を基準とする
Set rngResult = Workbooks("FILEA.xls").Worksheets("Sheet2").Range("A1")
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'「FILEB（SHEET1）」に就いて
With rngList2
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'A列データを配列に取得
vntKeys = .Offset(1).Resize(lngRows + 1).Value
'B列データを配列に得
vntItems = .Offset(1, 1).Resize(lngRows + 1).Value
End With
'FILEB（SHEET1）のA列Keyとして、金額をDictionaryに登録
With dicIndex
For i = 1 To lngRows
.Item(vntKeys(i, 1)) = vntItems(i, 1)
Next i
End With
'画面更新を停止
Application.ScreenUpdating = False
'「FILEA（SHEET1）」に就いて
With rngList1
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'A列データを配列に取得
vntKeys = .Offset(1).Resize(lngRows + 1).Value
'出力用配列を確保
ReDim vntItems(1 To lngRows, 1 To 1)
'0を代入
For i = 1 To lngRows
vntItems(i, 1) = 0
Next i
End With
'FILEA（SHEET1）のA列をDictionaryで辞書引き
With dicIndex
For i = 1 To lngRows
If .Exists(vntKeys(i, 1)) Then
vntItems(i, 1) = Val(.Item(vntKeys(i, 1)))
End If
Next i
End With
'結果を「FILEA（SHEET2）」に出力
With rngResult
.Offset(1).Resize(lngRows).Value = vntKeys
.Offset(1, 1).Resize(lngRows).Value = vntItems
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/3/11(木) 19:57 -
