xml
①control
②work
③difflist
④old
⑤new

MODULE1

Public Const titol_max = 100

Sub タイトル抽出()

Dim csh As Worksheet
Dim tsh As Worksheet
Dim titols_area As Range

Dim dirname As String
Dim filename As String

Dim ci As Long
Dim ss As String
Dim s As String
Dim k As Long
Dim N As Long
Dim ti As Long
Dim tj As Long
Dim tj_max As Long

Dim val

Const chk_string0 = "title"
Dim chk_len0 As Long
chk_len0 = Len(chk_string0)

Const chk_string1 = "resultHeading"
Dim chk_len1 As Long
chk_len1 = Len(chk_string1)

Const chk_string2 = "resultName"
Dim chk_len2 As Long
chk_len2 = Len(chk_string2)

Dim line_cnt(2) As Long
Dim ttop As Long
Dim body As Boolean
Dim titol As String
Dim resultHead As String
Dim resultName As String

Dim oldj As Long
Dim newj As Long
Dim oldend_j As Long
Dim newend_j As Long
Dim titol_unmatch As Long

Application.ScreenUpdating = False

Set csh = Worksheets("control")
For ci = 1 To 100
If csh.Cells(ci,1).Value = "●" Then GoTo mark_found
Next ci
Stop '●指定が無い

mark_found:
Set titols_area = csh.Range(Cells(ci + 5,5),Cells(ci + 7,titol_max + 4))
titols_area.Cells.ClearContents
line_cnt(1) = 0
line_cnt(2) = 0

For N = 1 To 2 '(N=1:旧、N=2:新)
ti = 1
ttop = 1

dirname = csh.Cells(ci + N,3).Value
filename = csh.Cells(ci + N,7).Value
Open dirname & filename For Input As #1

If N = 1 Then
Set tsh = Worksheets("old")
Else
Set tsh = Worksheets("new")
End If

tsh.Select
tsh.Cells.ClearContents

tsh.Cells(1,1).Value = chk_string0
tsh.Cells(1,2).Value = chk_string1
tsh.Cells(1,3).Value = chk_string2
titols_area.Cells(N,1).Value = chk_string0
titols_area.Cells(N,2).Value = chk_string1
titols_area.Cells(N,3).Value = chk_string2

While Not EOF(1)

'表タイトル識別、抽出
body = False
Line Input #1,ss
line_cnt(N) = line_cnt(N) + 1
'---------------------------------------------進捗状況表示
If line_cnt(N) Mod 100 = 1 Then
csh.Select
csh.Cells(5,6).Value = "旧：" & CStr(line_cnt(1)) & " 新：" & CStr(line_cnt(2))
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
'---------------------------------------------------------
k = InStr(ss,chk_string0)
If k > 0 Then
resultHead = Mid(ss,chk_len0 + k + 1) '=の次の文字から取得

Line Input #1,ss
line_cnt(N) = line_cnt(N) + 1
k = InStr(ss,chk_string1)
If k > 0 Then
resultName = Mid(ss,chk_len1 + k + 1) '=の次の文字から取得

Line Input #1,chk_string2)
If k > 0 Then
resultName = Mid(ss,chk_len2 + k + 1) '=の次の文字から取得
Else
Stop 'resultHeadの次の行は、resultNameが期待値
End If
Else
Stop 'resultHeadの次の行は、resultNameが期待値
End If
End If

'レコード開始チェック
If Trim(ss) = "<z:row" Then
body = True
ti = ti + 1
End If

'レコード内処理中
While body
Line Input #1,"=")
If k > 0 Then
titol = Trim(Left(ss,k - 1))
val = Trim(Mid(ss,k + 1))
tj = 3
While titols_area.Cells(N,tj).Value <> ""
If titols_area.Cells(N,tj).Value = titol Then
GoTo found
End If
tj = tj + 1
Wend
'titol not found
titols_area.Cells(N,tj).Value = titol
tsh.Cells(1,tj).Value = titol
tj_max = tj
found:
tsh.Cells(ti,1).Value = resultHead
tsh.Cells(ti,2).Value = resultName
tsh.Cells(ti,tj).Value = val
Else
body = False
End If
Wend
Wend
Close #1

csh.Cells(ci + N,12).Value = line_cnt(N)
csh.Cells(ci + N,13).Value = ti
csh.Cells(ci + N,14).Value = tj_max
Next N

'項目列マッチング
csh.Select
titol_unmatch = 0
oldend_j = csh.Cells(ci + 1,14).Value
newend_j = csh.Cells(ci + 2,14).Value
csh.Cells(ci + 5,4).Value = oldend_j
csh.Cells(ci + 6,4).Value = newend_j

For newj = 1 To newend_j
titol = titols_area.Cells(2,newj).Value

For oldj = 1 To oldend_j
If titols_area.Cells(1,oldj).Value = titol Then
titols_area.Cells(3,newj).Value = oldj
GoTo titol_found
End If
Next oldj
'oldにない
titols_area.Cells(3,newj).Value = ""
titol_unmatch = titol_unmatch + 1
titol_found:
Next newj

csh.Cells(ci + 9,4).Value = titol_unmatch

csh.Select
Application.ScreenUpdating = False
Set csh = Nothing
Set tsh = Nothing
Set titols_area = Nothing

End Sub

MODULE２

Sub 新旧シートの比較()

Dim csh As Worksheet
Dim wsh As Worksheet
Dim dsh As Worksheet
Dim oldsh As Worksheet
Dim newsh As Worksheet
Dim titols_area As Range
Dim unmatch_area As Range

Dim ci As Long
Dim wi As Long
Dim di As Long

Dim oldend_i As Long
Dim newend_i As Long
Dim oldend_j As Long
Dim newend_j As Long

Dim oldi As Long
Dim newi As Long
Dim oldj As Long
Dim newj As Long

Dim oldkeyj As Long 'マッチングkeyの列No
Dim newkeyj As Long
Dim oldkeysj(5) As Long '最大5ケのkey指定可能
Dim newkeysj(5) As Long
Dim key_cnt As Long '指定key数
Dim key_val As String
Dim k As Long

Dim keymatch_rec_cnt As Long
Dim record_match As Boolean
Dim record_match_cnt As Long
Dim work As String
Dim unmatch_titol As String

Dim i As Long
Dim i2 As Long
Dim j As Long
Dim j2 As Long
Dim old_col(titol_max) As Long
Dim unmatch(titol_max) As Boolean '新旧で一致ならtrue,不一致ならばfalse(行単位）
Dim checkType(titol_max) As String 'controlシートでの特殊処理指定

Dim titol As String
Dim titol_unmatch As Long
Dim key
Dim color_val As Long

Dim date02_y As String
Dim date02_m As String
Dim date02_d As String

Application.ScreenUpdating = False
Set csh = Worksheets("control")
Set wsh = Worksheets("work")
Set dsh = Worksheets("difflist")
Set oldsh = Worksheets("old")
Set newsh = Worksheets("new")


dsh.Cells.Clear

For ci = 1 To 100
If csh.Cells(ci,1).Value = "●" Then GoTo mark_found
Next ci
Stop '●指定が無い

mark_found:
'有効エリアを抽出したoldsh.newshの最終行列の取得
oldend_i = csh.Cells(ci + 1,13).Value
newend_i = csh.Cells(ci + 2,13).Value
oldend_j = csh.Cells(ci + 1,14).Value
csh.Cells(ci + 12,5).Value = oldend_i - 1
csh.Cells(ci + 13,5).Value = newend_i - 1

Set titols_area = csh.Range(Cells(ci + 5,Cells(ci + 8,titol_max + 4))
Set unmatch_area = csh.Range(Cells(ci + 15,Cells(ci + 17,titol_max + 4))

'新旧項目対応の配列初期化
For newj = 1 To newend_j
old_col(newj) = titols_area.Cells(3,newj).Value
checkType(newj) = titols_area.Cells(4,newj).Value
Next newj
'controlシートのアンマッチサマリエリア初期化
For i = 1 To 3
For j = 1 To titol_max
unmatch_area.Cells(i,j).Value = ""
Next j
Next i

'diffシートにヘッダ情報セット
di = di + 1
dsh.Cells(di,1).Value = "'" & String(100,"=")
dsh.Cells(di + 1,1).Value = "旧ファイル" & csh.Cells(ci + 1,7).Value
dsh.Cells(di + 2,1).Value = "新ファイル" & csh.Cells(ci + 2,7).Value
di = di + 3
dsh.Cells(di,1).Value = "項目名"
For j = 1 To newend_j
dsh.Cells(di,j + 1).Value = titols_area.Cells(2,j).Value
Next j

'マッチングkey
For k = 1 To 5
oldkeysj(k) = 0 'oldkeysj,newkeysjは、有効アリア内の相対列番号
newkeysj(k) = 0
Next k

key_cnt = 0
For j = 1 To newend_j
If checkType(j) = "key" Then
newkeyj = j
key_cnt = key_cnt + 1
If key_cnt > 5 Then Stop 'key指定が多すぎる
newkeysj(key_cnt) = j
oldkeyj = old_col(j)
If oldkeyj < 1 Then Stop
oldkeysj(key_cnt) = oldkeyj
End If
Next j
If key_cnt = 0 Then Stop 'key指定が無い

keymatch_rec_cnt = 0
record_match_cnt = 0

'key対応用ワークシート(wsh)の設定
wsh.Activate
wsh.Cells.Clear
wsh.Cells(1,1).Value = "旧ﾌｧｲﾙ"
wsh.Cells(1,3).Value = "旧key"
For i = 2 To oldend_i
wsh.Cells(i,2).Value = i
key_val = oldsh.Cells(i,oldkeysj(1)).Value
For k = 2 To key_cnt
key_val = key_val & "|" & oldsh.Cells(i,oldkeysj(k)).Value
Next k
wsh.Cells(i,3).NumberFormatLocal = "@"
wsh.Cells(i,3).Value = key_val
Next i
wsh.Cells(1,6).Value = "新ﾌｧｲﾙ"
wsh.Cells(1,8).Value = "新key"
For i = 2 To newend_i
wsh.Cells(i,7).Value = i
key_val = newsh.Cells(i,newkeysj(1)).Value
For k = 2 To key_cnt
key_val = key_val & "|" & newsh.Cells(i,newkeysj(k)).Value
Next k
wsh.Cells(i,8).NumberFormatLocal = "@"
wsh.Cells(i,8).Value = key_val
'newshのkeyを元に、oldshで同じkeyのレコードを探す

For i2 = 2 To oldend_i
If wsh.Cells(i2,3).Value = key_val Then
wsh.Cells(i2,4).Value = i
wsh.Cells(i,9).Value = i2
keymatch_rec_cnt = keymatch_rec_cnt + 1
GoTo key_found
End If
Next i2
'key_not found
' 特に処理はない（new olny)
key_found:
Next i
'キーマッチ行数表示
csh.Cells(ci + 12,6).Value = csh.Cells(ci + 12,5).Value - keymatch_rec_cnt
csh.Cells(ci + 13,6).Value = csh.Cells(ci + 13,5).Value - keymatch_rec_cnt
csh.Cells(ci + 12,7).Value = keymatch_rec_cnt

'相手のkeyの無い行のみ色替（最初に全体の色を消す）
' 旧
oldsh.Activate
oldsh.Cells.Interior.Color = RGB(255,255,255)
For oldi = 2 To oldend_i
If wsh.Cells(oldi,4).Value = "" Then
oldsh.Rows(CStr(oldi) & ":" & CStr(oldi)).Interior.Color = RGB(0,255)
End If
Next oldi
' 新
newsh.Activate
newsh.Cells.Interior.Color = RGB(255,255)
For newi = 2 To newend_i
If wsh.Cells(newi,9).Value = "" Then
newsh.Rows(CStr(newi) & ":" & CStr(newi)).Interior.Color = RGB(0,255)
End If
Next newi

For newi = 2 To newend_i
'---------------------------------------------進捗状況表示
If (newi Mod 10 = 2) Or (newi = newend_i) Then
csh.Activate
Application.ScreenUpdating = True
csh.Cells(6,6).Value = "'" & CStr(newi) & " / " & CStr(newend_i)
Application.ScreenUpdating = False
End If
'---------------------------------------------
oldi = CLng(wsh.Cells(newi,9).Value)
If oldi > 0 Then ' keyマッチ
' 項目単位チェック
record_match = True

For newj = 1 To newend_j
unmatch(newj) = True
If old_col(newj) = 0 Then GoTo next_col
oldj = old_col(newj)

'突合パターン別項目比較
Select Case checkType(newj)
Case "key","skip" '無視
GoTo cell_match
Case "" 'そのままの値でチェック
If newsh.Cells(newi,newj).Value = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "date01"
work = Replace(oldsh.Cells(oldi,oldj).Value,"-","/",1,2,vbTextCompare)
If newsh.Cells(newi,newj).Value = work Then GoTo cell_match
Case "BZ" '旧の0と新のNullは同一とみなす
If oldsh.Cells(oldi,oldj).Value = 0 Then
If newsh.Cells(newi,newj).Value = "" Then GoTo cell_match
End If
If newsh.Cells(newi,oldj).Value Then GoTo cell_match
'***************************特殊な突合パターンがあれば、ここに追加する**********************
Case "date02"
date02_y = "20" & Mid(newsh.Cells(newi,newj),6,2)
date02_m = Mid(newsh.Cells(newi,3,3)
date02_d = Mid(newsh.Cells(newi,2)
Select Case date02_m
Case "JAN"
If date02_y & "-01-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "FEB"
If date02_y & "-02-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "MAR"
If date02_y & "-03-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "APR"
If date02_y & "-04-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "MAY"
If date02_y & "-05-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "JUN"
If date02_y & "-06-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "JUL"
If date02_y & "-07-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "AUG"
If date02_y & "-08-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "SEP"
If date02_y & "-09-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "OCT"
If date02_y & "-10-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "NOV"
If date02_y & "-11-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case "DEC"
If date02_y & "-12-" & date02_d = oldsh.Cells(oldi,oldj).Value Then GoTo cell_match
Case Else
Stop
End Select

Case "date03"
work = Replace(oldsh.Cells(oldi,"",vbTextCompare)
work = Replace(work,"T00:00:00",newj).Value = work Then GoTo cell_match

Case "case"
If UCase(newsh.Cells(newi,newj).Value) = UCase(oldsh.Cells(oldi,oldj).Value) Then GoTo cell_match
'******************************ここまで追加した突合パターン*********************************
Case Else
Stop
End Select
'cell unmatch
record_match = False
unmatch(newj) = False

'controlシートへのアンマッチサマリ反映
unmatch_titol = titols_area.Cells(2,newj).Value
j2 = 1
While unmatch_area.Cells(1,j2).Value <> ""
If unmatch_area.Cells(1,j2).Value = unmatch_titol Then GoTo already_set
j2 = j2 + 1
Wend
'アンマッチ項目名未登録
unmatch_area.Cells(1,j2).Value = unmatch_titol
unmatch_area.Cells(2,j2).Value = "旧=" & CStr(oldj) & ",新=" & CStr(newj)
already_set:
unmatch_area.Cells(3,j2).Value = unmatch_area.Cells(3,j2).Value + 1
GoTo next_col
cell_match:
next_col:
Next newj
GoTo record_check_end
Else
'new_rec_only(旧が見つからない）
record_match = False
End If

record_check_end:
If record_match Then
record_match_cnt = record_match_cnt + 1
ElseIf oldi > 0 Then
'アンマッチがあるので、diffシートに 旧、新のレコードを表示
dsh.Cells(di + 1,1).Value = "旧"
dsh.Cells(di + 2,1).Value = "新"

' 旧色替
oldsh.Activate
For newj = 1 To newend_j
If unmatch(newj) = False Then
oldj = old_col(newj)
oldsh.Range(Cells(oldi,oldj),Cells(oldi,oldj)).Interior.Color = RGB(0,255)
End If
Next newj
' 新色替
newsh.Activate
For newj = 1 To newend_j
If unmatch(newj) = False Then
newsh.Range(Cells(newi,Cells(newi,newj)).Interior.Color = RGB(0,255)
End If
Next newj
' diffシート色替＆値セット
dsh.Activate
For newj = 1 To newend_j
If old_col(newj) = 0 Then
dsh.Cells(di + 1,newj + 1).Value = "<対象なし>"
Else
oldj = old_col(newj)
dsh.Cells(di + 1,newj + 1).Value = "'" & CStr(oldsh.Cells(oldi,oldj).Value)
If unmatch(newj) = False Then
dsh.Range(Cells(di + 1,newj + 1),Cells(di + 1,newj + 1)).Interior.Color = RGB(0,255)
End If
End If '文字列に変換してセット
dsh.Cells(di + 2,newj + 1).Value = "'" & CStr(newsh.Cells(newi,newj).Value)
Next newj
di = di + 2

End If
Next newi

'ファイル突合サマリ表示（全項目一致したレコード件数）
csh.Cells(ci + 12,8).Value = record_match_cnt

csh.Select Application.ScreenUpdating = True Set csh = Nothing Set oldsh = Nothing Set newsh = Nothing Set titols_area = Nothing Set unmatch_area = Nothing End Sub