|
▼Hirofumi さん:
できました!!
1時から発表なので今手作業でやってたんですが、ほんと助かりました!
ありがとうございました!
>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
|
|