Excel VBA質問箱 IV

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

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


18487 / 76736 ←次へ | 前へ→

【63691】Re:教えて下さい
回答  Hirofumi  - 09/11/30(月) 12:13 -

引用なし
パスワード
   Sheet1、Sheet2共に列見出しが在る物とします

Option Explicit

Public Sub DataMatch3()

'  同一データのチェック
'  Dictionary版

  'Sheet1のデータ列数(A列)
  Const clngColumns1 As Long = 1
  'Sheet1のKey列(A列)の位置設定(基準位置からの列Offset)
  Const clngKey1 As Long = 0
  
  'Sheet2のデータ列数(A列〜B列)
  Const clngColumns2 As Long = 2
  'Sheet2のKey列(A列)の位置設定(基準位置からの列Offset)
  Const clngKey2 As Long = 0
  
  Dim i As Long
  Dim rngList1 As Range
  Dim lngRows1 As Long
  Dim vntKeys1 As Variant
  Dim rngList2 As Range
  Dim lngRows2 As Long
  Dim vntKeys2 As Variant
  Dim rngResult As Range
  Dim lngWrite As Long
  Dim dicIndex As Object
  Dim strProm As String

  'Sheet1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Range("A1")
  
  'Sheet2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet2").Range("A1")
  
  'Sheet3結果シートのA1を基準とする
  Set rngResult = Worksheets("Sheet3").Range("A1")

  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '画面更新を停止
  Application.ScreenUpdating = False
    
  'Sheet1の基準に就いて、Key列データと行数取得
  If Not GetBasicData(rngList1, lngRows1, clngKey1, vntKeys1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2の基準に就いて、Key列データと行数取得
  If Not GetBasicData(rngList2, lngRows2, clngKey2, vntKeys2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2のKeyデータと行位置をDictionaryに登録
  With dicIndex
    '最終行に達するまで繰り返し
    For i = 1 To lngRows2
      'Dictionaryに登録
      .Item(vntKeys2(i, 1)) = i
    Next i
    'Sheet1のKeyデータをDictionaryで比較し在ったら転記
    For i = 1 To lngRows1
      'Dictionaryに登録が有る場合集計
      If .Exists(vntKeys1(i, 1)) Then
        '出力位置を更新
        lngWrite = lngWrite + 1
        'Sheet3のA列にSheet2シートの該当行を出力
        rngList2.Offset(.Item(vntKeys1(i, 1))).Resize(, clngColumns2).Copy _
            Destination:=rngResult.Offset(lngWrite)
      End If
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set dicIndex = Nothing
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

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

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

End Function

0 hits

【40838】教えて下さい 初心者 06/7/25(火) 3:55 質問
【40842】Re:教えて下さい だるま 06/7/25(火) 8:28 回答
【40846】Re:教えて下さい 注意 06/7/25(火) 9:22 発言
【40980】Re:教えて下さい 初心者 06/7/27(木) 11:04 お礼
【40898】Re:教えて下さい Hirofumi 06/7/25(火) 21:05 回答
【40981】Re:教えて下さい 初心者 06/7/27(木) 11:09 お礼
【63685】Re:教えて下さい 黄身 09/11/30(月) 3:51 質問
【63686】Re:教えて下さい Hirofumi 09/11/30(月) 8:46 回答
【63687】Re:教えて下さい 黄身 09/11/30(月) 9:08 発言
【63691】Re:教えて下さい Hirofumi 09/11/30(月) 12:13 回答
【63692】Re:教えて下さい 黄身 09/11/30(月) 12:24 お礼

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