EXCEL比較ツール

Excel
①control
②work
③difflist
④old
⑤new

MODULE１

Public Const titol_max = 400

Sub タイトル抽出()
    Dim csh As Worksheet
    Dim oldsh As Worksheet
    Dim newsh As Worksheet
    Dim tbook As Workbook
    Dim tsh As Worksheet
    Dim dataArea As Range
  
    Dim titols_area As Range
   
    Dim fullpath As String
    Dim shname As String
   
    Dim start_i As Long
    Dim start_j As Long
    Dim end_i As Long
    Dim end_j As Long
   
    Dim ci As Long
    Dim i As Long
    Dim j As Long
    Dim oldj As Long
    Dim newj As Long
    Dim col_max(2) As Long
   
    Dim titol As String
    Dim titol_unmatch As Long
    Dim ti As Long
    Dim tj As Long
   
    Dim N As Long ' N=1:old, N=2:new
   
    Application.ScreenUpdating = False
   
    Set csh = Worksheets("control")
    Set oldsh = Worksheets("old")
    Set newsh = Worksheets("new")
   
    oldsh.Cells.Clear
    newsh.Cells.Clear
   
    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 + 8, 103))
    For i = 1 To 3
        For j = 1 To titol_max
            titols_area.Cells(i, j).Value = ""
        Next j
    Next i
               
    For N = 1 To 2
'book読込
        'ホルダ名の最後に"\"がないときは、追加しておく
        If Right(csh.Cells(ci + N, 3).Value, 1) <> "\" Then
            csh.Cells(ci + N, 3).Value = csh.Cells(ci + N, 3).Value & "\"
        End If
        fullpath = csh.Cells(ci + N, 3).Value & csh.Cells(ci + N, 7).Value
        shname = Trim(csh.Cells(ci + N, 9).Value)
           
        Workbooks.Open fullpath
        Set tbook = ActiveWorkbook
        If shname = "" Then
            Set tsh = tbook.Worksheets(1)
        Else
            Set tsh = tbook.Worksheets(shname)
        End If

'新旧book内の有効位置取得
        start_i = csh.Cells(ci + N, 11).Value
        start_j = csh.Cells(ci + N, 12).Value
        end_i = tsh.UsedRange.Row + tsh.UsedRange.Rows.Count - 1
        end_j = tsh.UsedRange.Column + tsh.UsedRange.Columns.Count - 1
               
        csh.Cells(ci + N, 13).Value = end_i
        csh.Cells(ci + N, 14).Value = end_j
'タイトル抽出
        j = 1
        While tsh.Cells(start_i, start_j + j - 1).Value <> ""
            titols_area.Cells(N, j).Value = LCase(StrConv(tsh.Cells(start_i, start_j + j - 1).Value, vbNarrow))
            j = j + 1
            If j > titol_max Then Stop '項目数オーバー
        Wend
        col_max(N) = j - 1
        csh.Cells(ci + 4 + N, 4).Value = j - 1 '項目数

        Set dataArea = tsh.Range(Cells(start_i, start_j), Cells(end_i, end_j))
        dataArea.Cells.Select
        Selection.Copy
        If N = 1 Then
            oldsh.Activate
        Else
            newsh.Activate
        End If
        Range("A1").Select
        ActiveSheet.Paste
        Range("A1").Select
               
'bookクローズ
        Application.DisplayAlerts = False
        tbook.Saved = True
        tbook.Close
    Next N
           
'新旧項目マッチング
    csh.Select
    titol_unmatch = 0
    For newj = 1 To col_max(2)
        titol = titols_area.Cells(2, newj).Value
        For oldj = 1 To col_max(1)
            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
   
    Set titols_area = Nothing
    Set dataArea = Nothing
    Set csh = Nothing
    Set oldsh = Nothing
    Set newsh = Nothing
    Set tbook = Nothing
    Set tsh = 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