Option Explicit
Public Bln_Err As Boolean
Public Twb As Workbook
Public wsComp As Worksheet
Sub SetObject()
Set Twb = ThisWorkbook
Set wsComp = Twb.Worksheets("比較結果")
End Sub
Sub ReSetObject()
Set Twb = Nothing
Set wsComp = Nothing
End Sub
'*****************************************************
' 画面制御セット
' Call StopUpdating
'*****************************************************
Sub StopUpdating()
With Application
.ScreenUpdating = False '画面描画停止
.EnableEvents = False 'イベント動作停止
.EnableCancelKey = xlErrorHandler '[Esc]キーでエラーをトラップする
'=========================
'.EnableCancelKey = xlInterrupt '[Esc]キーでVBAの実行を止める(なかなか止まらない)
'.EnableCancelKey = xlErrorHandler '[Esc]キーでエラーをトラップする
'On Error GoTo ★★★_Err と使用する
'.EnableCancelKey =xlDisabled '[Esc]キーを無効にする
'=========================
' .Cursor = xlWait
'計算設定取得
Call yourCalc("比較結果", "R2")
.DisplayAlerts = False '警告非表示
.DisplayStatusBar = True 'ステータスバーを表示
End With
End Sub
'*****************************************************
' 画面制御セット
' Call Updating
'*****************************************************
Sub Updating()
With Application
.ScreenUpdating = True '画面描画再開
.EnableEvents = True 'イベント動作再開
.Cursor = xlDefault
.DisplayAlerts = True '警告再表示
'計算設定を戻す
Call RestoreCalc("比較結果", "R2")
.StatusBar = False
'ステータスバーを表示
End With
End Sub
'+++***********************************************+++
' 自動/手動計算設定取得
' Call yourCalc("Main","A2")
'+++***********************************************+++
Public Function yourCalc(shtName As String, strRng As String)
'エラーを無視
On Error Resume Next
With ThisWorkbook.Worksheets(shtName)
With .Range(strRng)
.Font.Color = .Interior.Color
If Application.Calculation = xlCalculationAutomatic Then
.Value = 1
ElseIf Application.Calculation = xlCalculationManual Then
.Value = 2
ElseIf Application.Calculation = xlCalculationSemiautomatic Then
.Value = 3
End If
End With
End With
'エラー制御を戻す
On Error GoTo 0
End Function
'+++***********************************************+++
' 自動/手動計算を最初の設定に戻す
' Call RestoreCalc("Main","A2")
'+++***********************************************+++
Public Function RestoreCalc(shtName As String, strRng As String)
'エラーを無視
On Error Resume Next
With ThisWorkbook.Worksheets(shtName)
With .Range(strRng)
.Font.Color = .Interior.Color
If .Value = 1 Then
Application.Calculation = xlCalculationAutomatic
ElseIf .Value = 2 Then
Application.Calculation = xlCalculationManual
ElseIf .Value = 3 Then
Application.Calculation = xlCalculationSemiautomatic
End If
End With
End With
'エラー制御を戻す
On Error GoTo 0
End Function
'-----------------------------------------------------
' ステータスバーを使用する
' Call showStatus(msg)
'-----------------------------------------------------
Public Sub showStatus(ByVal MSG As String)
'エラーを無視
On Error Resume Next
ThisWorkbook.Activate
ActiveWindow.WindowState = xlMaximized
Application.StatusBar = MSG
DoEvents
'エラー制御を戻す
On Error GoTo 0
End Sub
'-----------------------------------------------------
' ステータスバーをClear
' Call clrStatus
'-----------------------------------------------------
Public Sub clrStatus()
'エラーを無視
On Error Resume Next
DoEvents
Application.StatusBar = False
'エラー制御を戻す
On Error GoTo 0
End Sub
'-----------------------------------------------------
' OSに制御を渡す
' Call exeBreak
'-----------------------------------------------------
Public Sub exeBreak()
'エラーを無視
On Error Resume Next
DoEvents
'エラー制御を戻す
On Error GoTo 0
End Sub
'+++***********************************************+++
' シート検出
' Call IsShtOwb(shtName, OtrwbName)
'+++***********************************************+++
Public Function IsShtOwb(shtName As String, wbName As String) As Boolean
Dim sht As Worksheet
Dim Otrwb As Workbook
IsShtOwb = False
Set Otrwb = Workbooks(wbName)
For Each sht In Otrwb.Worksheets
If sht.Name = shtName Then
IsShtOwb= True
Set Otrwb = Nothing
Exit Function
End If
Next sht
'エラーを無視
On Error Resume Next
Set Otrwb = Nothing
'エラー制御を戻す
On Error GoTo 0
End Function
' +++*******************************************************+++
' アクティブシートのシェイプを全削除
' +++*******************************************************+++
Public Sub delShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next
End Sub
コメント