Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

17433 / 76732

←次へ　｜　前へ→


	【64752】Re:ファイル間の検索と更新

Hirofumi - 10/3/11(木) 19:57 -


	引用なし

	パスワード

こんなのでは？

「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

1 hits

▼

【64750】ファイル間の検索と更新 ムーン 10/3/11(木) 18:16