Excel VBA質問箱 IV

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

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


17431 / 76732 ←次へ | 前へ→

【64754】Re:ファイル間の検索と更新
お礼  ムーン  - 10/3/12(金) 8:42 -

引用なし
パスワード
   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

0 hits

【64750】ファイル間の検索と更新 ムーン 10/3/11(木) 18:16 質問
【64752】Re:ファイル間の検索と更新 Hirofumi 10/3/11(木) 19:57 回答
【64754】Re:ファイル間の検索と更新 ムーン 10/3/12(金) 8:42 お礼
【64771】Re:ファイル間の検索と更新 ムーン 10/3/12(金) 15:40 お礼

17431 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free