Excel VBA質問箱 IV

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

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


3018 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   いつもありがとうございます。

早速ですが、どなたかヘルプお願い致します。

したいこと

FILEA(SHEET1)

 A  B 
1 1 1000
2 2 1000
3 3 2000
4 4 3000
5 5 2000
: : :
: : :

FILEB(SHEET1)・・FILEA(SHEET1)の更新されたもの
 A  B 
1 1 500
2 2 1000
3 5 2000
4 : :
: : :
: : :

結果欲しいもの

FILEA(SHEET2)

 A  B 
1 1 500
2 2 1000
3 3 0
4 4 0
5 5 2000
: : :
: : :


・FILEA(SHEET1)とFILEB(SHEET1)は同じ並びの項目
・FILEA(SHEET1)のA列とFILEB(SHEET1)のA列を比較
(FILEA(SHEET1)のA列の値がある間)

■上記、FILEAのSHEET2の結果が欲しいのです。

FILEB(SHEET1)のA列はIDで、B列は金額です。

FILEB(SHEET1)のA列のIDが無くなっているのは
B列の金額が0になったからです。

しかし結果のFILEAのSHEET2にはA列のIDは全て残したまま
B列の金額には0を入れます。

また、A列同士の比較で、結果のFILEAのSHEET2のB列は
FILEBのB列の金額を入れます。


少し細かいですが、宜しくお願い致します。

【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

【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

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

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

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