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
MODULE2
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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|