|
Hirofumi さん
おはようございます。
早速のご返答ありがとうございます。
一度試してみます。
取り急ぎ、御礼まで。
▼Hirofumi さん:
>こんなのでは?
>
>「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
|
|