XML比較ツール

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, ss
                    line_cnt(N) = line_cnt(N) + 1
                    k = InStr(ss, 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, 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, "=")
                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
    newend_j = csh.Cells(ci + 2, 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, 5), Cells(ci + 8, titol_max + 4))
    Set unmatch_area = csh.Range(Cells(ci + 15, 5), 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, 255)
        End If
    Next oldi
'       新
    newsh.Activate
    newsh.Cells.Interior.Color = RGB(255, 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, 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, newj).Value = oldsh.Cells(oldi, oldj).Value Then GoTo cell_match
'***************************特殊な突合パターンがあれば、ここに追加する**********************
                Case "date02"
                    date02_y = "20" & Mid(newsh.Cells(newi, newj), 6, 2)
                    date02_m = Mid(newsh.Cells(newi, newj), 3, 3)
                    date02_d = Mid(newsh.Cells(newi, newj), 1, 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, oldj).Value, "-", "", 1, 2, vbTextCompare)
                    work = Replace(work, "T00:00:00", "", 1, 2, vbTextCompare)
                    If newsh.Cells(newi, 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, 255)
                End If
            Next newj
'           新色替
            newsh.Activate
            For newj = 1 To newend_j
                If unmatch(newj) = False Then
                    newsh.Range(Cells(newi, newj), Cells(newi, newj)).Interior.Color = RGB(0, 255, 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, 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