| |
データが無いので試していませんが？
Sheet1、Sheet2共に列見出しが有る物とします
Sheet1、Sheet2共に比較する列をKeyとして整列されます
Sheet1、Sheet2に共通する比較値が有る場合は、
Sheet2のＣ〜Ｆ列にSheet1のＢ〜Ｅ列の値を貼り付け
Option Explicit
Option Compare Text
Public Sub DataMatch()
'Sheet1のデータ列数（A列〜E列）
Const clngColumns1 As Long = 5
'Sheet1の比較する列の列位置(基準セル位置からの列Offset)
Const clngKeys1 As Long = 0
'Sheet2のデータ列数（C列〜G列）
Const clngColumns2 As Long = 5
'Sheet2の比較する列の列位置(基準セル位置からの列Offset)
Const clngKeys2 As Long = 4
Dim i As Long
Dim j As Long
Dim lngStart As Long
Dim rngList1 As Range
Dim vntList1 As Variant
Dim lngRows1 As Long
Dim rngList2 As Range
Dim vntList2 As Variant
Dim lngRows2 As Long
Dim strProm As String
'Sheet1のA1を基準とします
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'Sheet2のD1を基準とする
Set rngList2 = Worksheets("Sheet2").Cells(1, "C")
'画面更新を停止
Application.ScreenUpdating = False
'Sheet1の基準に就いて
With rngList1
'行数を取得
lngRows1 = .Offset(Rows.Count - .Row, _
clngKeys1).End(xlUp).Row - .Row
'データが無ければ
If lngRows1 <= 0 Then
strProm = rngList1.Value & "にデータが有りません"
GoTo Wayout
End If
'データをA列で整列
DataSort .Offset(1).Resize(lngRows1, _
clngColumns1 + 1), .Offset(1, clngKeys1)
'比較用配列にデータを取得
vntList1 = .Offset(1, clngKeys1).Resize(lngRows1 + 1).Value
End With
'Sheet2基準に就いて
With rngList2
'行数を取得
lngRows2 = .Offset(Rows.Count - .Row, _
clngKeys2).End(xlUp).Row - .Row
'データが無ければ
If lngRows2 <= 0 Then
strProm = rngList2.Value & "にデータが有りません"
GoTo Wayout
End If
'データをG列で整列
DataSort .Offset(1).Resize(lngRows2, _
clngColumns2 + 1), .Offset(1, clngKeys2)
'比較用配列にデータを取得
vntList2 = .Offset(1, clngKeys2).Resize(lngRows2 + 1).Value
End With
'Sheet2の比較開始位置を設定
lngStart = 1
For i = 1 To lngRows1
For j = lngStart To lngRows2
'Matchiした場合
If vntList1(i, 1) = vntList2(j, 1) Then
'Sheet2のＣ〜Ｆ列にSheet1のＢ〜Ｅ列の値を貼り付け
rngList2.Offset(j).Resize(, 4).Value _
= rngList1.Offset(i, 1).Resize(, 4).Value
Else
'Sheet1の値がSheet2の値より小さい場合、Forを抜ける
If vntList1(i, 1) < vntList2(j, 1) Then
Exit For
End If
End If
Next j
'D列の比較開始位置を更新
lngStart = j
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 07/7/13(金) 17:39 -
