| |
どうも質問しているレイアウトと本物のレイアウトが違っている様ですし、
Matchした時の記載も、Sheet2のC列は日付で、D列以降はSheet1のD列〜Z列の転記の様なので
結果の出力を配列を使ってC列に一気に出力するのでは無く、1行づつ転記する様に変更しました
尚、以下4つのプロシージャは、「Sub DataMatch」の時と同じ物を使います
Private Function GetBasicData
Private Sub DataRestore
Private Sub DataSort
Private Function DataCompare
以下を上記のプロシージャと同じ標準モジュールに記述して下さい
Option Explicit
Option Compare Text
Public Sub DataMatch3()
'◆Sheet1のデータ列数（A列〜Z列）
Const clngColumns1 As Long = 26
'◆Sheet2のデータ列数（A列〜Z列）
Const clngColumns2 As Long = 26
'◆Sheet1からSheet2転記する先頭列位置（基準セル位置からの列の列Offsetを指定）
Const clngStart As Long = 3
'◆転記する列数（D列〜Z列の23列）
Const clngNumb As Long = 23
Dim i As Long
Dim rngList1 As Range
Dim vntList1 As Variant
Dim lngRows1 As Long
Dim lngComp1 As Long
Dim vntKeys1 As Variant
Dim rngList2 As Range
Dim vntList2 As Variant
Dim lngRows2 As Long
Dim lngComp2 As Long
Dim vntKeys2 As Variant
Dim lngMatch As Long
Dim lngAppend As Long
Dim strProm As String
'Sheet1データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'Sheet2データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys1 = Array(0, 1)
'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys2 = Array(0, 1)
'Sheet1の比較データを保持する配列を確保
ReDim vntList1(0 To UBound(vntKeys1))
'Sheet2の比較データを保持する配列を確保
ReDim vntList2(0 To UBound(vntKeys1))
'画面更新を停止
Application.ScreenUpdating = False
'Sheet1の基準に就いて
If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Sheet2基準に就いて
If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'追加位置の初期値
lngAppend = lngRows2
'Sheet1のシートの比較位置
lngComp1 = 1
'Sheet2のシートの比較位置
lngComp2 = 1
'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
'各列のデータを比較
lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
With rngList2
'日付を記入
.Offset(lngComp2, clngStart - 1).Value = Date
'Sheet1のD列以降を転記
rngList1.Offset(lngComp1, clngStart).Resize(, clngNumb).Copy _
Destination:=.Offset(lngComp2, clngStart)
End With
'Sheet1、Sheet2のシートの比較位置を更新
lngComp1 = lngComp1 + 1
lngComp2 = lngComp2 + 1
Case Is = -1 'Sheet1の固有値の場合
'Sheet2の最終行にデータを追加
lngAppend = lngAppend + 1
With rngList2
'A、B列を転記
For i = 0 To UBound(vntKeys2)
.Offset(lngAppend, vntKeys2(i)).Value = vntList1(i)(lngComp1, 1)
Next i
'Sheet1のD列以降を転記
rngList1.Offset(lngComp1, clngStart).Resize(, clngNumb).Copy _
Destination:=.Offset(lngAppend, clngStart)
End With
'Sheet1のシートの比較位置を更新
lngComp1 = lngComp1 + 1
Case Is = 1 'Sheet2の固有値の場合
'Sheet2のシートの比較位置を更新
lngComp2 = lngComp2 + 1
End Select
Loop
'Sheet1のシートの順位を復帰
DataRestore rngList1, lngRows1, clngColumns1
'Sheet2のシートの順位を復帰
DataRestore rngList2, lngRows2, clngColumns2
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/8/17(日) 0:39 -
