TEXT比較ツール

txt
①control
②work
③difflist
④old_org
⑤old
⑥new_org
⑦new

 

MODULE1

Public Const titol_max = 100

Sub 旧テキスト読込()
Attribute 旧テキスト読込.VB_ProcData.VB_Invoke_Func = " \n14"

'
    ChDir _
        "\\mankey\千葉銀行\11.バージョンアップ\V5.7.0\05.結合テスト\01.AsIsリグレッション\04.エビデンス\AsIsリグレッション_13_帳票\バッチ\V53\1-1-12"
    Workbooks.OpenText filename:= _
        "\\mankey\千葉銀行\11.バージョンアップ\V5.7.0\05.結合テスト\01.AsIsリグレッション\04.エビデンス\AsIsリグレッション_13_帳票\バッチ\V53\1-1-12\SPL_summit_RESETREP_CBKTEST_0730_000.txt" _
        , Origin:=932, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 2), Array(21, 2), Array(26, 2), Array(37, 2), Array(46, 2), Array(49, 2), Array(52 _
        , 2), Array(58, 2), Array(66, 2), Array(76, 2), Array(86, 2), Array(96, 2)), _
        TrailingMinusNumbers:=True
End Sub
Sub 新テキスト読込()
Attribute 新テキスト読込.VB_ProcData.VB_Invoke_Func = " \n14"
'
    ChDir _
        "\\mankey\千葉銀行\11.バージョンアップ\V5.7.0\05.結合テスト\01.AsIsリグレッション\04.エビデンス\AsIsリグレッション_13_帳票\バッチ\V57\1-1-12"
    Workbooks.OpenText filename:= _
        "\\mankey\千葉銀行\11.バージョンアップ\V5.7.0\05.結合テスト\01.AsIsリグレッション\04.エビデンス\AsIsリグレッション_13_帳票\バッチ\V57\1-1-12\SPL_summit_RESETREP_CBKTEST_0730_000.txt" _
        , Origin:=932, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 2), Array(16, 2), Array(26, 2), Array(35, 2), Array(49, 2), Array(59, 2), Array(62 _
        , 2), Array(65, 2), Array(71, 2), Array(76, 2), Array(81, 2), Array(97, 2), Array(104, 2), _
        Array(113, 2), Array(123, 2)), TrailingMinusNumbers:=True
End Sub

Sub タイトル抽出()
    Dim csh As Worksheet
    Dim dsh As Worksheet
    Dim orgdsh As Worksheet
    Dim di As Long
    Dim dj As Long
    Dim org_di As Long
    Dim org_dj As Long
    Dim titols_area As Range
   
    Dim filename As String
    Dim newfilename As String
    Dim org_maxi As Long
    Dim org_maxj As Long
    Dim i As Long
    Dim j As Long
    Dim ci As Long
    Dim N As Long
   
    Dim oldj As Long
    Dim newj As Long
   
    Dim titol As String
    Dim titol_unmatch As Long
   
    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
   
    For N = 1 To 2

        Application.DisplayAlerts = False
       
        filename = csh.Cells(ci + N, 3).Value
        If N = 1 Then
            Set dsh = Worksheets("old")
            Set orgdsh = Worksheets("old_org")
            dsh.Cells.Clear
            orgdsh.Cells.Clear
            Call 旧テキスト読込
        Else
            Set dsh = Worksheets("new")
            Set orgdsh = Worksheets("new_org")
            dsh.Cells.Clear
            orgdsh.Cells.Clear
            Call 新テキスト読込
        End If

        Windows(filename).Activate
        Cells.Select
        Selection.Copy
        orgdsh.Activate
        orgdsh.Cells(1, 1).Select
        ActiveSheet.Paste
        Windows(filename).Activate
        ActiveWindow.Close
        org_maxi = orgdsh.UsedRange.Rows.Count
        csh.Cells(ci + N, 12).Value = org_maxi

'   有効データをoosh⇒osh,nosh⇒nshにコピーする
'   (補足)改頁はAsc(Left(対象セル, 1))=12 で判断
       
        For dj = 1 To titol_max
            titol = ""
            For di = csh.Cells(ci + N, 8) To csh.Cells(ci + N, 9).Value
                titol = titol & orgdsh.Cells(di, dj).Value
            Next di
            If titol = "" Then
                org_maxj = dj - 1
                GoTo step01
            End If
            dsh.Cells(1, dj).Value = titol
            titols_area.Cells(N, dj).Value = titol
        Next dj
        Stop  'タイトル列>titol_max
step01:
        di = 1
        orgdsh.Activate
        For org_di = csh.Cells(ci + N, 10).Value To org_maxi
            If orgdsh.Cells(org_di, 1).Value <> "" Then
                If Asc(Left(orgdsh.Cells(org_di, 1).Value, 1)) = 12 Then '改頁
                    org_di = org_di + csh.Cells(ci + N, 11).Value - 2
                Else
                    di = di + 1
                    For dj = 1 To org_maxj
                        dsh.Cells(di, dj).Value = "'" & CStr(orgdsh.Cells(org_di, dj).Value)
                    Next dj
                    orgdsh.Range(Cells(org_di, 1), Cells(org_di, 1)).Interior.Color = RGB(0, 255, 255)
                End If
            End If
        Next org_di
        csh.Cells(ci + N, 13).Value = di
        csh.Cells(ci + N, 14).Value = org_maxj
        csh.Cells(ci + N + 4, 4).Value = org_maxj
    Next N
'------------------------------------------------------------------------
'新旧項目マッチング
    csh.Select
    titol_unmatch = 0
    For newj = 1 To csh.Cells(ci + 2, 14).Value
        titol = titols_area.Cells(2, newj).Value
        For oldj = 1 To csh.Cells(ci + 1, 14).Value
            If titols_area.Cells(1, oldj).Value = titol Then
                titols_area.Cells(3, newj).Value = oldj
                GoTo found
            End If
        Next oldj
'oldにない
        titols_area.Cells(4, newj).Value = ""
        titol_unmatch = titol_unmatch + 1
found:
    Next newj
    csh.Cells(ci + 9, 4).Value = titol_unmatch

    csh.Select
    Application.ScreenUpdating = True
'=====================================================================================
    csh.Select
    Set titols_area = Nothing
    Set csh = Nothing
    Set orgdsh = Nothing
    Set dsh = 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
   
    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 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