| |
試して無いけど、こんな物で出来るかも？
ただし、夫々のシートには、列見出しが有る物とします
また、Sheet1、Sheet2共に同一シート内では重複が無い物とします
Option Explicit
Option Compare Text
Public Sub UpDate()
'"Sheet1"のデータ列数（A〜B列）
Const clngColumns1 As Long = 2
'"Sheet1"の比較Key列位置（基準からB列の列Offset値）
Const clngKeys1 As Long = 1
'"Sheet2"のデータ列数（A列〜D列）
Const clngColumns2 As Long = 4
'"Sheet2"の比較Key列位置（基準からD列の列Offset値）
Const clngKeys2 As Long = 3
'C列に書き込む記号
Const cstrSign As String = "*"
Dim i As Long
Dim rngList1 As Range
Dim lngEnd1 As Long
Dim vntData1 As Variant
Dim lngRow1 As Long
Dim vntItems As Variant
Dim rngList2 As Range
Dim lngEnd2 As Long
Dim vntData2 As Variant
Dim lngRow2 As Long
Dim vntResult As Variant
Dim strProm As String
'Sheet1のA1を基準とします（列見出し先頭のセル位置）
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'Sheet2のA1を基準とする（列見出し先頭のセル位置）
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
'"Sheet1"データの基準に就いて基礎データの取得
If Not GetBasicData(rngList1, lngEnd1, _
clngColumns1, clngKeys1, vntData1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'"Sheet1"のA列を配列に取得
vntItems = rngList1.Offset(1).Resize(lngEnd1 + 1).Value
'"Sheet2"データの基準に就いて基礎データの取得
If Not GetBasicData(rngList2, lngEnd2, _
clngColumns2, clngKeys2, vntData2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'"Sheet2"のD列に出力する為の配列を確保します
ReDim vntResult(1 To lngEnd2, 1 To 1)
'"Sheet1"の比較位置
lngRow1 = 1
'"Sheet2"の比較位置
lngRow2 = 1
'"Sheet1"若しくは、"Sheet2"が最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'比較結果に就いて
Select Case vntData1(lngRow1, 1)
Case Is = vntData2(lngRow2, 1) 'Matchiした場合
'結果出力用配列に番号を代入
vntResult(lngRow2, 1) = vntItems(lngRow1, 1)
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntData2(lngRow2, 1) '"Sheet2"固有値の場合
'結果出力用配列に記号を代入
vntResult(lngRow2, 1) = cstrSign
'"Sheet2"の比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntData2(lngRow2, 1) '"Sheet1"固有値の場合
'"Sheet1"の比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
'"Sheet2"に残ったデータを処理("Sheet2"固有値)
For i = lngRow2 To lngEnd2
'結果出力用配列に記号を代入
vntResult(i, 1) = cstrSign
Next i
'結果を出力
rngList2.Offset(1, 2).Resize(lngEnd2).Value = vntResult
'"Sheet1"データの復旧
DataRestore rngList1, lngEnd1, clngColumns1
'"Sheet2"データの復旧
DataRestore rngList2, lngEnd2, clngColumns2
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetBasicData(rngList As Range, _
lngRows As Long, _
lngColumns As Long, _
lngKeys As Long, _
vntData As Variant) As Boolean
Dim i As Long
Dim lngNumb() As Long
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(65536 - .Row, _
lngKeys).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows < 0 Then
Exit Function
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngRows, 1 To 1)
For i = 1 To lngRows
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力列を挿入
.Offset(1, lngColumns).EntireColumn.Insert
'復帰用Keyの出力
.Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
'データをlngKeys列で整列
.Offset(1).Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
End With
GetBasicData = True
End Function
Private Sub DataRestore(rngList As Range, _
lngRows As Long, _
lngColumns As Long)
'データの復旧
With rngList
'元データ順位を復帰
.Offset(1).Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'復帰用Key列を削除
.Offset(, lngColumns).EntireColumn.Delete
End With
End Sub
|
|
Hirofumi
- 06/7/28(金) 21:15 -
