Embedded Files
EXCEL VBA Sample
' コード一覧表 VBA ScriptDeclare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Sub Alignment_Click() Dim sht_in1 As Worksheet Dim sht_in2 As Worksheet Dim sht_cmp As Worksheet
Dim old_code As String Dim old_codeid As String Dim old_codenm As String Dim old_codevid As String Dim old_codevalue As String Dim new_code As String Dim new_codeid As String Dim new_codenm As String Dim new_codevid As String Dim new_codevalue As String Dim wstring1 As String Dim wstring2 As String Dim msgString As String Dim StartTime, StopTime As Variant Dim foundCell As Range
Dim lastRow As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim i, j, forDebug As Long Dim maxStep As Long Dim step As Long Dim result As Long
Dim blnSaveStatus As Boolean Dim sCount As Integer Dim mCount As Integer Dim strBarNow As String Dim strBarWk As String
wstring1 = ActiveSheet.Range("D2") Set sht_in1 = Worksheets(wstring1) wstring2 = ActiveSheet.Range("D3") Set sht_in2 = Worksheets(wstring2) Set sht_cmp = Worksheets("コード値内容突合シート")
'E列 J列の最終行を取得 lastRow1 = sht_cmp.Cells(Rows.Count, 5).End(xlUp).Row lastRow2 = sht_cmp.Cells(Rows.Count, 10).End(xlUp).Row lastRow = WorksheetFunction.Max(lastRow1, lastRow2, 6) ' 行を削除 Range("6:" & lastRow).Delete ' 削除 blnSaveStatus = Application.DisplayStatusBar Application.DisplayStatusBar = True strBarNow = " 0%:□□□□□□□□□□" Application.StatusBar = strBarNow result = MsgBox("新旧シートの取込を開始しますか？", vbYesNo + vbExclamation) If result = vbYes Then 'Yesを選択され場合の処理 '処理を継続 Else 'Noを選択された場合の処理 Application.ScreenUpdating = True ' 画面の更新を再開する Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Exit Sub End If
'ここから実行時間のカウントを開始する StartTime = Time
'D列(コード値の内容)の最終行を取得 lastRow1 = sht_in1.Cells(Rows.Count, 4).End(xlUp).Row lastRow2 = sht_in2.Cells(Rows.Count, 4).End(xlUp).Row sht_cmp.Range("E4") = "最終行：" & lastRow1 sht_cmp.Range("J4") = "最終行：" & lastRow2
maxStep = lastRow1 + lastRow2 - 10 sht_in1.Range("A6:D" & lastRow1).Copy Destination:=sht_cmp.Range("B6") sht_in2.Range("A6:D" & lastRow2).Copy Destination:=sht_cmp.Range("G6") sht_cmp.Range("A6").Formula = "=B6&""_""&D6" sht_cmp.Range("A6").Copy sht_cmp.Range("A7:A" & lastRow1).PasteSpecial Paste:=xlPasteFormulas sht_cmp.Range("F6").Formula = "=G6&""_""&I6" sht_cmp.Range("F6").Copy sht_cmp.Range("F7:F" & lastRow2).PasteSpecial Paste:=xlPasteFormulas sht_cmp.Range("G6").Select
i = 6 j = 6 old_codeid = sht_cmp.Cells(i, "B") old_codenm = sht_cmp.Cells(i, "C") old_codevid = sht_cmp.Cells(i, "D") old_codevalue = sht_cmp.Cells(i, "E") new_codeid = sht_cmp.Cells(j, "G") new_codenm = sht_cmp.Cells(i, "H") new_codevid = sht_cmp.Cells(j, "I") new_codevalue = sht_cmp.Cells(i, "J") Application.ScreenUpdating = False ' 画面の更新を止める For i = 6 To lastRow1 If sht_cmp.Cells(i, "B") = "" Then sht_cmp.Cells(i, "B") = old_codeid Else old_codeid = sht_cmp.Cells(i, "B") End If If sht_cmp.Cells(i, "C") = "" Then sht_cmp.Cells(i, "C") = old_codenm Else old_codenm = sht_cmp.Cells(i, "C") End If
sCount = Fix((i - 5) / (lastRow1 + lastRow2 - 10) * 100) ' 進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Next i For j = 6 To lastRow2 If sht_cmp.Cells(j, "G") = "" Then sht_cmp.Cells(j, "G") = new_codeid Else new_codeid = sht_cmp.Cells(j, "G") End If If sht_cmp.Cells(j, "H") = "" Then sht_cmp.Cells(j, "H") = new_codenm Else new_codenm = sht_cmp.Cells(j, "H") End If
sCount = Fix((lastRow1 + j - 10) / (lastRow1 + lastRow2 - 10) * 100) ' 進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Next j
StopTime = Time StopTime = StopTime - StartTime
Application.ScreenUpdating = True ' 画面の更新を再開する MsgBox "シートの取込準備が整いました。" & vbCrLf _ & "取込の所要時間は" & Minute(StopTime) & "分" & Second(StopTime) & "秒でした。" result = MsgBox("版数差異チェックを開始しますか？", vbYesNo + vbExclamation) If result = vbYes Then ' Yesを選択され場合の処理 ' 処理を継続 Else ' Noを選択された場合の処理 Application.ScreenUpdating = True ' 画面の更新を再開する Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Exit Sub End If 'ここから実行時間のカウントを開始する StartTime = Time Application.ScreenUpdating = False ' 画面の更新を止める
strBarNow = "0% : □□□□□□□□□□" Application.StatusBar = strBarNow i = 6 j = 6 ' 1行ずつチェック Do While i <= lastRow1 Or j <= lastRow2 If i > 702 Then 'forDebug = i / 0 End If
Set foundCell = sht_cmp.Range("F6:F" & lastRow2).Find(What:=sht_cmp.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole) If foundCell Is Nothing Then sht_cmp.Cells(i, "L") = "削除" If j <= lastRow2 Then sht_cmp.Range("F" & j & ":J" & lastRow2).Cut j = j + 1 lastRow2 = lastRow2 + 1 sht_cmp.Range("F" & j).Select ActiveSheet.Paste End If i = i + 1 End If
Set foundCell = sht_cmp.Range("A6:A" & lastRow1).Find(What:=sht_cmp.Cells(j, "F"), LookAt:=xlWhole) If foundCell Is Nothing Then sht_cmp.Cells(j, "L") = "追加" If i <= lastRow1 Then sht_cmp.Range("A" & i & ":E" & lastRow1).Cut i = i + 1 lastRow1 = lastRow1 + 1 sht_cmp.Range("A" & i).Select ActiveSheet.Paste End If j = j + 1 End If
If sht_cmp.Range("A" & i) = sht_cmp.Range("F" & j) And sht_cmp.Range("A" & i) <> "" Then If sht_cmp.Range("C" & i) <> sht_cmp.Range("H" & j) Then sht_cmp.Cells(i, "L") = "変更(コード名)" sht_cmp.Range("C" & i).Font.Color = RGB(0, 255, 0) sht_cmp.Range("H" & i).Font.Color = RGB(0, 0, 255) End If If sht_cmp.Range("E" & i) <> sht_cmp.Range("J" & j) Then If sht_cmp.Range("C" & i) <> sht_cmp.Range("H" & j) Then sht_cmp.Cells(i, "L") = "変更(コード名+コード値)" Else sht_cmp.Cells(i, "L") = "変更(コード値)" End If sht_cmp.Range("E" & i).Font.Color = RGB(0, 255, 0) sht_cmp.Range("J" & i).Font.Color = RGB(0, 0, 255) End If If i <> j Then MsgBox "新旧の位置がずれています。旧: " & i & "←→新: " & j & vbCrLf _ & "終了します。" Exit Do End If i = i + 1 j = j + 1 End If
If sht_cmp.Range("A" & i) = "" And sht_cmp.Range("F" & j) = "" Then Exit Do End If
sCount = Fix((WorksheetFunction.Max(i, j) - 5) / (WorksheetFunction.Max(lastRow1, lastRow2) - 5) * 100) '進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Loop
'Application.ScreenUpdating = True ' 画面の更新を再開する
'sht_cmp.Range("L6").Copy 'sht_cmp.Range("L7:L" & lastRow2).PasteSpecial Paste:=xlPasteFormulas 'sht_cmp, Range("M6").Copy 'sht_cmp.Range("M7: M" & lastRow1).PasteSpecial Paste:=xlPasteFormulas 'sht_cmp, Range("N6").Copy 'sht_cmp.Range("N7:N" & Worksheet Function.Max(lastRow1, lastRow2)).PasteSpecial Paste:=xlPasteValues
Range("B6:E" & lastRow1).Borders.LineStyle = xlContinuous Range("G6:J" & lastRow2).Borders.LineStyle = xlContinuous Range("L6:M" & WorksheetFunction.Max(lastRow1, lastRow2)).Borders.LineStyle = xlContinuous
StopTime = Time StopTime = StopTime - StartTime
Application.ScreenUpdating = True ' 画面の更新を再開する MsgBox "互換性チェックが終了しました。" & vbCrLf _ & "所要時間は" & Minute(StopTime) & "分" & Second(StopTime) & "秒でした。" Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Application.DisplayStatusBar = False
sht_cmp.Select sht_cmp.Range("A1").SelectEnd Sub
' コード一覧表 VBA ScriptDeclare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Sub Alignment_Click() Dim sht_in1 As Worksheet Dim sht_in2 As Worksheet Dim sht_cmp As Worksheet
Dim old_code As String Dim old_codeid As String Dim old_codenm As String Dim old_codevid As String Dim old_codevalue As String Dim new_code As String Dim new_codeid As String Dim new_codenm As String Dim new_codevid As String Dim new_codevalue As String Dim wstring1 As String Dim wstring2 As String Dim msgString As String Dim StartTime, StopTime As Variant Dim foundCell As Range
Dim lastRow As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim i, j, forDebug As Long Dim maxStep As Long Dim step As Long Dim result As Long
Dim blnSaveStatus As Boolean Dim sCount As Integer Dim mCount As Integer Dim strBarNow As String Dim strBarWk As String
wstring1 = ActiveSheet.Range("D2") Set sht_in1 = Worksheets(wstring1) wstring2 = ActiveSheet.Range("D3") Set sht_in2 = Worksheets(wstring2) Set sht_cmp = Worksheets("コード値内容突合シート")
'E列 J列の最終行を取得 lastRow1 = sht_cmp.Cells(Rows.Count, 5).End(xlUp).Row lastRow2 = sht_cmp.Cells(Rows.Count, 10).End(xlUp).Row lastRow = WorksheetFunction.Max(lastRow1, lastRow2, 6) ' 行を削除 Range("6:" & lastRow).Delete ' 削除 blnSaveStatus = Application.DisplayStatusBar Application.DisplayStatusBar = True strBarNow = " 0%:□□□□□□□□□□" Application.StatusBar = strBarNow result = MsgBox("新旧シートの取込を開始しますか？", vbYesNo + vbExclamation) If result = vbYes Then 'Yesを選択され場合の処理 '処理を継続 Else 'Noを選択された場合の処理 Application.ScreenUpdating = True ' 画面の更新を再開する Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Exit Sub End If
'ここから実行時間のカウントを開始する StartTime = Time
'D列(コード値の内容)の最終行を取得 lastRow1 = sht_in1.Cells(Rows.Count, 4).End(xlUp).Row lastRow2 = sht_in2.Cells(Rows.Count, 4).End(xlUp).Row sht_cmp.Range("E4") = "最終行：" & lastRow1 sht_cmp.Range("J4") = "最終行：" & lastRow2
maxStep = lastRow1 + lastRow2 - 10 sht_in1.Range("A6:D" & lastRow1).Copy Destination:=sht_cmp.Range("B6") sht_in2.Range("A6:D" & lastRow2).Copy Destination:=sht_cmp.Range("G6") sht_cmp.Range("A6").Formula = "=B6&""_""&D6" sht_cmp.Range("A6").Copy sht_cmp.Range("A7:A" & lastRow1).PasteSpecial Paste:=xlPasteFormulas sht_cmp.Range("F6").Formula = "=G6&""_""&I6" sht_cmp.Range("F6").Copy sht_cmp.Range("F7:F" & lastRow2).PasteSpecial Paste:=xlPasteFormulas sht_cmp.Range("G6").Select
i = 6 j = 6 old_codeid = sht_cmp.Cells(i, "B") old_codenm = sht_cmp.Cells(i, "C") old_codevid = sht_cmp.Cells(i, "D") old_codevalue = sht_cmp.Cells(i, "E") new_codeid = sht_cmp.Cells(j, "G") new_codenm = sht_cmp.Cells(i, "H") new_codevid = sht_cmp.Cells(j, "I") new_codevalue = sht_cmp.Cells(i, "J") Application.ScreenUpdating = False ' 画面の更新を止める For i = 6 To lastRow1 If sht_cmp.Cells(i, "B") = "" Then sht_cmp.Cells(i, "B") = old_codeid Else old_codeid = sht_cmp.Cells(i, "B") End If If sht_cmp.Cells(i, "C") = "" Then sht_cmp.Cells(i, "C") = old_codenm Else old_codenm = sht_cmp.Cells(i, "C") End If
sCount = Fix((i - 5) / (lastRow1 + lastRow2 - 10) * 100) ' 進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Next i For j = 6 To lastRow2 If sht_cmp.Cells(j, "G") = "" Then sht_cmp.Cells(j, "G") = new_codeid Else new_codeid = sht_cmp.Cells(j, "G") End If If sht_cmp.Cells(j, "H") = "" Then sht_cmp.Cells(j, "H") = new_codenm Else new_codenm = sht_cmp.Cells(j, "H") End If
sCount = Fix((lastRow1 + j - 10) / (lastRow1 + lastRow2 - 10) * 100) ' 進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Next j
StopTime = Time StopTime = StopTime - StartTime
Application.ScreenUpdating = True ' 画面の更新を再開する MsgBox "シートの取込準備が整いました。" & vbCrLf _ & "取込の所要時間は" & Minute(StopTime) & "分" & Second(StopTime) & "秒でした。" result = MsgBox("版数差異チェックを開始しますか？", vbYesNo + vbExclamation) If result = vbYes Then ' Yesを選択され場合の処理 ' 処理を継続 Else ' Noを選択された場合の処理 Application.ScreenUpdating = True ' 画面の更新を再開する Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Exit Sub End If 'ここから実行時間のカウントを開始する StartTime = Time Application.ScreenUpdating = False ' 画面の更新を止める
strBarNow = "0% : □□□□□□□□□□" Application.StatusBar = strBarNow i = 6 j = 6 ' 1行ずつチェック Do While i <= lastRow1 Or j <= lastRow2 If i > 702 Then 'forDebug = i / 0 End If
Set foundCell = sht_cmp.Range("F6:F" & lastRow2).Find(What:=sht_cmp.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole) If foundCell Is Nothing Then sht_cmp.Cells(i, "L") = "削除" If j <= lastRow2 Then sht_cmp.Range("F" & j & ":J" & lastRow2).Cut j = j + 1 lastRow2 = lastRow2 + 1 sht_cmp.Range("F" & j).Select ActiveSheet.Paste End If i = i + 1 End If
Set foundCell = sht_cmp.Range("A6:A" & lastRow1).Find(What:=sht_cmp.Cells(j, "F"), LookAt:=xlWhole) If foundCell Is Nothing Then sht_cmp.Cells(j, "L") = "追加" If i <= lastRow1 Then sht_cmp.Range("A" & i & ":E" & lastRow1).Cut i = i + 1 lastRow1 = lastRow1 + 1 sht_cmp.Range("A" & i).Select ActiveSheet.Paste End If j = j + 1 End If
If sht_cmp.Range("A" & i) = sht_cmp.Range("F" & j) And sht_cmp.Range("A" & i) <> "" Then If sht_cmp.Range("C" & i) <> sht_cmp.Range("H" & j) Then sht_cmp.Cells(i, "L") = "変更(コード名)" sht_cmp.Range("C" & i).Font.Color = RGB(0, 255, 0) sht_cmp.Range("H" & i).Font.Color = RGB(0, 0, 255) End If If sht_cmp.Range("E" & i) <> sht_cmp.Range("J" & j) Then If sht_cmp.Range("C" & i) <> sht_cmp.Range("H" & j) Then sht_cmp.Cells(i, "L") = "変更(コード名+コード値)" Else sht_cmp.Cells(i, "L") = "変更(コード値)" End If sht_cmp.Range("E" & i).Font.Color = RGB(0, 255, 0) sht_cmp.Range("J" & i).Font.Color = RGB(0, 0, 255) End If If i <> j Then MsgBox "新旧の位置がずれています。旧: " & i & "←→新: " & j & vbCrLf _ & "終了します。" Exit Do End If i = i + 1 j = j + 1 End If
If sht_cmp.Range("A" & i) = "" And sht_cmp.Range("F" & j) = "" Then Exit Do End If
sCount = Fix((WorksheetFunction.Max(i, j) - 5) / (WorksheetFunction.Max(lastRow1, lastRow2) - 5) * 100) '進捗率(%) mCount = Fix(sCount / 10) ' 10個マスだから10%単位 strBarWk = sCount & "%：" & String(mCount, "■") & String(10 - mCount, "□") If (strBarWk <> strBarNow) Then Application.StatusBar = strBarWk ' 変化がある時だけバー更新 strBarNow = strBarWk End If Loop
'Application.ScreenUpdating = True ' 画面の更新を再開する
'sht_cmp.Range("L6").Copy 'sht_cmp.Range("L7:L" & lastRow2).PasteSpecial Paste:=xlPasteFormulas 'sht_cmp, Range("M6").Copy 'sht_cmp.Range("M7: M" & lastRow1).PasteSpecial Paste:=xlPasteFormulas 'sht_cmp, Range("N6").Copy 'sht_cmp.Range("N7:N" & Worksheet Function.Max(lastRow1, lastRow2)).PasteSpecial Paste:=xlPasteValues
Range("B6:E" & lastRow1).Borders.LineStyle = xlContinuous Range("G6:J" & lastRow2).Borders.LineStyle = xlContinuous Range("L6:M" & WorksheetFunction.Max(lastRow1, lastRow2)).Borders.LineStyle = xlContinuous
StopTime = Time StopTime = StopTime - StartTime
Application.ScreenUpdating = True ' 画面の更新を再開する MsgBox "互換性チェックが終了しました。" & vbCrLf _ & "所要時間は" & Minute(StopTime) & "分" & Second(StopTime) & "秒でした。" Application.StatusBar = False ' ステータスバーの制御をExcelに戻す Application.DisplayStatusBar = False
sht_cmp.Select sht_cmp.Range("A1").SelectEnd Sub
Page updated
Report abuse