| |
出遅れました
もし、"vicky-com"、"com"の各々のシートの中でKeyが重複していた時
例えば、"vicky-com"に2つ同じKeyが有り、其のKeyが"com"にも1つ有った場合
"vicky-com"の最初のKeyと、"com"のKeyがMatchと見なされ転記されます
同じく、"vicky-com"、"com"に同じKeyが2つづつ有った場合、
両方がMatchと見なされ転記されます
尚、"vicky-com"、"com"各々は、H列、J列を作業列として使います
Option Explicit
Public Sub DataMatch()
' データの転記
'"vicky-com"のデータ列数（A列〜J列）
Const clngColumns1 As Long = 10
'"vicky-com"の比較Key列位置（G列）
Const clngKeys1 As Long = 7
'"com"のデータ列数（A列〜O列）
Const clngColumns2 As Long = 15
'"com"の比較Key列位置（I列）
Const clngKeys2 As Long = 9
Dim i As Long
Dim rngList1 As Range
Dim lngEnd1 As Long
Dim vntList1 As Variant
Dim lngRow1 As Long
Dim rngList2 As Range
Dim lngEnd2 As Long
Dim vntList2 As Variant
Dim lngRow2 As Long
Dim rngMatch1 As Range
Dim rngMatch2 As Range
Dim lngWrite As Long
Dim lngNumb() As Long
Dim strProm As String
'"vicky-com"データシートのA1を基準とします（列見出しのセル位置）
Set rngList1 = Worksheets("vicky-com").Cells(1, "A")
'基準に就いて
With rngList1
'行数を取得
lngEnd1 = .Offset(65536 - .Row, _
clngKeys1 - 1).End(xlUp).Row - .Row
If lngEnd1 < 0 Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngEnd1, 1 To 1)
For i = 1 To lngEnd1
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns1).Resize(lngEnd1).Value = lngNumb
'データをclngKeys1列で整列
DataSort .Offset(1).Resize(lngEnd1, _
clngColumns1 + 1), .Offset(1, clngKeys1 - 1)
End With
'"com"データシートのA1を基準とする（列見出しのセル位置）
Set rngList2 = Worksheets("com").Cells(1, "A")
'基準に就いて
With rngList2
'行数を取得
lngEnd2 = .Offset(65536 - .Row, _
clngKeys2 - 1).End(xlUp).Row - .Row
If lngEnd2 < 0 Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngEnd2, 1 To 1)
For i = 1 To lngEnd2
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns2).Resize(lngEnd2).Value = lngNumb
'データをclngKeys2列で整列
DataSort .Offset(1).Resize(lngEnd2, _
clngColumns2 + 1), .Offset(1, clngKeys2 - 1)
End With
'"hit"出力シートの出力位置を設定
Set rngMatch1 = Worksheets("hit").Cells(1, "A")
Set rngMatch2 = rngMatch1.Parent.Cells(1, "K")
'画面更新を停止
Application.ScreenUpdating = False
'"vicky-com"シートの比較位置
lngRow1 = 1
'"com"シートの比較位置
lngRow2 = 1
'"vicky-com"シート若しくは、"com"シートが最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'各シートのデータ1行分の後半を配列に取得
vntList1 = rngList1.Offset(lngRow1).Resize(, clngColumns1).Value
vntList2 = rngList2.Offset(lngRow2).Resize(, clngColumns2).Value
'比較結果に就いて
Select Case vntList1(1, clngKeys1)
Case Is = vntList2(1, 1) 'Matchiした場合
'書き込み行を更新
lngWrite = lngWrite + 1
'"vicky-com"シートの行を"hit"シートにCopy
rngList1.Offset(lngRow1).Resize(, clngColumns1).Copy _
Destination:=rngMatch1.Offset(lngWrite)
'"com"シートの行を"hit"シートにCopy
rngList2.Offset(lngRow2).Resize(, clngColumns2).Copy _
Destination:=rngMatch2.Offset(lngWrite)
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntList2(1, clngKeys2) '"com"シート固有値の場合
'"com"シートの比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntList2(1, clngKeys2) '"vicky-com"シート固有値の場合
'"vicky-com"シートの比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
With rngList1
'元データを復帰
DataSort .Offset(1).Resize(lngEnd1, _
clngColumns1 + 1), .Offset(1, clngColumns1)
'復帰用Key列を削除
.Offset(, clngColumns1).EntireColumn.Delete
End With
With rngList2
'元データを復帰
DataSort .Offset(1).Resize(lngEnd2, _
clngColumns2 + 1), .Offset(1, clngColumns2)
'復帰用Key列を削除
.Offset(, clngColumns2).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngMatch1 = Nothing
Set rngMatch2 = 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
- 06/4/23(日) 17:03 -
