Option Explicit
Public Sub 新比較()
Dim ssh As Worksheet
Dim msh As Worksheet
Dim sbsh As Worksheet
Dim wrow As Long
Dim wcol As Long
Dim wcols As String
Dim trow As Long
Dim tcol As Long
Dim tcols As String
Dim maxrow_s, maxrow_m, maxrow_t As Long
Dim dicT1 As Object '項目管理(シート1)キー:列の値 内容:列名
Dim dicT2 As Object '項目管理(シート2)キー:列の値 内容:列名
Dim dicTw As Object '項目管理 キー:列名 内容:0又は1(0=列名重複なし、1=列名重複あり)
Dim dicTX As Object '項目管理(シート1)キー:列の値 内容:列名(但し同じ列名には連番を付加)
Dim dicN1 As Object '項目管理(シート1)キー:列名 内容:行番号
Dim dicN2 As Object '項目管理(シート2)キー:列名 内容:行番号
Dim dicR As Object '項目管理(シート1/2)キー:シート1の列の値 内容:シート2の列の値
Dim ser_m As String 'ユニークキー列(シート1)
Dim ser_t As String 'ユニークキー列(シート2)
Dim Key As Variant
Dim item As Variant
Dim RC As Variant
Dim SetFile As Variant
Dim newSh As Worksheet
Dim mwb As Workbook
Dim twb As Workbook
Dim tsh As Worksheet
Dim maxrow_s2 As Long
Dim rng As Range
Dim sts_m As String 'ステータス列
Set ssh = Worksheets("設定")
Set dicT1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicT2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicTw = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicTX = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicN1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicN2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicR = CreateObject("Scripting.Dictionary") ' 連想配列の定義
'/////////////////////////////////コモンダイアログから転記先のシートを開く
RC = MsgBox("書き込むファイルを選択してください。", vbYesNo + vbQuestion, "確認")
If RC = vbNo Then Exit Sub
SetFile = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
If SetFile = "False" Then
MsgBox "キャンセルしました"
Exit Sub
End If
Set mwb = Workbooks.Open(SetFile)
Set msh = mwb.Worksheets("管理表")
Worksheets.Add After:=msh
Set newSh = ActiveSheet
newSh.name = "差分"
Set sbsh = Worksheets("差分")
'/////////////////////////////////後で書き換えます◎
Sheets("管理表").Select
Rows("1:4").Select
Selection.Copy
Sheets("差分").Select
Rows("1:1").Select
ActiveSheet.Paste
Application.DisplayAlerts = True
Application.CutCopyMode = True
'/////////////////////////////////最大行の取得し、設定シートに記載した列を取得
sts_m = ssh.Range("O3").Value 'ステータス列
maxrow_s = ssh.Cells(Rows.Count, "G").End(xlUp).Row 'A列の最大行取得
maxrow_s2 = ssh.Cells(Rows.Count, "L").End(xlUp).Row '追加回答者 L列の最大行取得
Set rng = ssh.Range("L2:L" & maxrow_s2) '追加回答者
ser_m = ""
ser_t = ""
'設定シート列取得
For wrow = 3 To maxrow_s
dicT1(ssh.Cells(wrow, "H").Value) = ssh.Cells(wrow, "G").Value
dicT2(ssh.Cells(wrow, "I").Value) = ssh.Cells(wrow, "G").Value
dicR(ssh.Cells(wrow, "H").Value) = ssh.Cells(wrow, "I").Value
If ssh.Cells(wrow, "G").Value = "ユニークキー" Then
ser_m = ssh.Cells(wrow, "H").Value
ser_t = ssh.Cells(wrow, "I").Value
End If
Key = ssh.Cells(wrow, "G").Value
If dicTw.Exists(Key) = False Then
dicTw(Key) = 0
Else
dicTw(Key) = 1
End If
Next
'重複している列のみを残す
For Each Key In dicTw.keys()
If dicTw(Key) = 0 Then
dicTw.Remove (Key)
End If
Next
'重複している列に連番を付加する
For wrow = 3 To maxrow_s
Key = ssh.Cells(wrow, "G").Value
dicTX(ssh.Cells(wrow, "H").Value) = Key
If dicTw.Exists(Key) = True Then
dicTX(ssh.Cells(wrow, "H").Value) = dicTX(ssh.Cells(wrow, "H").Value) & dicTw(Key)
dicTw(Key) = dicTw(Key) + 1
End If
Next
If ser_m = "" Then
MsgBox ("設定シートに「ユニークキー」の項目なし")
Exit Sub
End If
'項目の列位置チェック
For Each item In dicT1.keys()
If msh.Cells(4, item).Value <> dicT1(item) Then
msh.Cells(4, item).Interior.Color = vbYellow
MsgBox ("シート1の列名不正:" & item & "=" & dicT1(item))
Exit Sub
End If
Next
maxrow_m = msh.Cells(Rows.Count, ser_m).End(xlUp).Row 'sheet1 ユニークキー列の最大行取得
'ユニークキーの行を記憶
For wrow = 5 To maxrow_m
dicN1(msh.Cells(wrow, ser_m).Value) = wrow
Next
RC = MsgBox("参照するファイルを選択してください。", vbYesNo + vbQuestion, "確認")
If RC = vbNo Then Exit Sub
SetFile = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
If SetFile = "False" Then
MsgBox "キャンセルしました"
Exit Sub
End If
Set twb = Workbooks.Open(SetFile)
Set tsh = twb.Worksheets("管理表")
'項目の列位置チェック
For Each item In dicT2
If tsh.Cells(3, item).Value <> dicT2(item) Then
MsgBox ("シート2の列名不正:" & item & "=" & dicT2(item))
Exit Sub
End If
Next
maxrow_t = tsh.Cells(Rows.Count, ser_t).End(xlUp).Row 'sheet1 ユニークキー列の最大行取得
'ユニークキーの行を記憶
For wrow = 4 To maxrow_t
dicN2(tsh.Cells(wrow, ser_t).Value) = wrow
Next
'DE,DF列をクリア
msh.Range("DE5:DE" & maxrow_m).Value = ""
msh.Range("DE5:DE" & maxrow_m).Interior.Pattern = xlNone
msh.Range("DF5:DF" & maxrow_m).Value = ""
msh.Range("DF5:DF" & maxrow_m).Interior.Pattern = xlNone
'/////////////////////////////////比較⇒処理
For wrow = 5 To maxrow_m
Key = msh.Cells(wrow, ser_m).Value
If IfInstrs(msh.Cells(wrow, ser_m).Value, rng) = True Then
If msh.Cells(wrow, sts_m).Value = "設計OK" Or msh.Cells(wrow, sts_m).Value = "検討中" Then
If dicN2.Exists(Key) = False Then
'シート1にありシート2にないユニークキーの処理
msh.Cells(wrow, "DE").Value = "レコード削除"
msh.Cells(wrow, "DE").Interior.Color = vbYellow
Else
trow = dicN2(Key)
For Each item In dicR.keys()
If item <> ser_m Then
wcols = item
tcols = dicR(item)
If msh.Cells(wrow, wcols).Value = "" _
And tsh.Cells(trow, tcols).Value = "" Then
Else
'転記処理'
If msh.Cells(wrow, wcols).Value = "" Or msh.Cells(wrow, wcols).Value = "-" Then
msh.Cells(wrow, wcols).Value = Trim(tsh.Cells(trow, tcols).Value) '前後の空白を削除して転記
'Debug.Print wcols, msh.Cells(wrow, wcols).Column
msh.Cells(wrow, "DE").Value = add_colName(msh.Cells(wrow, "DE").Value, dicTX(item))
msh.Cells(wrow, wcols).Interior.Color = vbCyan
Else
'元データがあり差分がある場合、DE列に「変更あり」を記載し、黄色く色付け
'差分ファイルに転記し色付け
If msh.Cells(wrow, wcols).Value <> tsh.Cells(trow, tcols).Value Then
msh.Cells(wrow, "DF").Interior.Color = vbYellow
msh.Cells(wrow, "DF").Value = add_colName(msh.Cells(wrow, "DF").Value, dicTX(item))
msh.Cells(wrow, wcols).Interior.Color = vbYellow
sbsh.Cells(wrow, wcols).Value = tsh.Cells(trow, tcols).Value
sbsh.Cells(wrow, wcols).Interior.Color = vbYellow
End If
End If
End If
End If
Next
dicN2.Remove (Key)
End If
End If
End If
Next
'/////////////////////////////////ユニークキーが追加されるようなことがある場合、ここをアクティブにする
'シート2にありシート1にないユニークキーを追加する
'wrow = maxrow_m + 1
'For Each Key In dicN2
' trow = dicN2(Key)
' For Each item In dicR '修正2020/3/14
' wcols = item '修正2020/3/14
' tcols = dicR(item) '修正2020/3/14
' msh.Cells(wrow, wcols).Value = tsh.Cells(trow, tcols).Value
' Next
' wrow = wrow + 1
'Next
'/////////////////////////////////ファイルを閉じて完了
Application.DisplayAlerts = False
twb.Close False
Application.DisplayAlerts = True
MsgBox "完了しました"
End Sub
Private Function IfInstrs(ByVal word As String, ByVal rng As Range) As Boolean
Dim wrg As Range
For Each wrg In rng
If InStr(1, word, wrg.Value) > 0 Then
IfInstrs = True
Exit Function
End If
Next
IfInstrs = False
End Function
Private Function add_colName(ByVal str As String, ByVal name As String) As String
If str = "" Then
add_colName = name
Else
add_colName = str & "/" & name
End If
End Function