Excel VBA質問箱 IV

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

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


24697 / 76732 ←次へ | 前へ→

【57383】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/16(土) 19:10 -

引用なし
パスワード
   Dictionary版

Option Explicit
'Option Compare Text

Public Sub DataMatch2()

  'Sheet1のデータ列数(A列〜B列)
  Const clngColumns1 As Long = 2
  'Sheet2のデータ列数(A列〜C列)
  Const clngColumns2 As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim rngList1 As Range
  Dim vntList As Variant
  Dim lngRows As Long
  Dim vntKeys As Variant
  Dim rngList2 As Range
  Dim vntResult As Variant
  Dim lngAppend As Long
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String

  'Sheet1データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  'Sheetの比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys = Array(0, 1)
  
  'Sheetの比較データを保持する配列を確保
  ReDim vntList(0 To UBound(vntKeys))
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows, clngColumns2, vntKeys, vntList) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '結果出力用配列を確保
  ReDim vntResult(1 To lngRows, 1 To 1)
  '追加位置を記録
  lngAppend = lngRows
  'DictionaryにSheet2のデータを登録
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
      If Not .Exists(vntKey) Then
        .Item(vntKey) = i
      End If
    Next i
  End With
      
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows, clngColumns1, vntKeys, vntList) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
      If .Exists(vntKey) Then
        vntResult(.Item(vntKey), 1) = "合致"
      Else
        'Sheet2の最終行にデータを追加
        lngAppend = lngAppend + 1
        With rngList2.Offset(lngAppend)
          .Value = vntList(0)(i, 1)
          .Offset(, 1).Value = vntList(1)(i, 1)
        End With
      End If
    Next i
  End With
  '結果を出力
  rngList2.Offset(1, clngColumns2 - 1).Resize(UBound(vntResult, 1)).Value = vntResult

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set dicIndex = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function
2 hits

【57381】2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 17:36 質問
【57382】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 18:38 回答
【57383】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 19:10 回答
【57386】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 20:52 質問
【57388】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 23:08 回答
【57389】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 23:19 回答
【57390】Re:2つの条件での分岐・書き込み Hirofumi 08/8/17(日) 0:39 回答
【57393】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/17(日) 15:33 発言
【57384】Re:2つの条件での分岐・書き込み kanabun 08/8/16(土) 19:12 発言
【57385】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 19:57 発言

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