趣味プログラミングblog

---

Option Explicit '変数を先に宣言しなさいよ
Const debugFlag = 1


'Private Function getColNo(列1)
'Function get2dDicArr(colX As Long, colY As Long, tGyo As Long, edGyo As Long)
Sub ◆2列集計dic()

Dim strFlag As String: strFlag = 0 & "," & 0 & "," & 0 & "," & 0
Call ◆2列集計dic_main(strFlag)
End Sub


Sub ◆2列集計dic_rmNum()
'対象の２列を決定
Dim 列1 As Long: 列1 = Selection(1).Column
Dim 列2 As Long: 列2 = getCol2No()

Dim rmXflag: rmXflag = 7 - MsgBox(getStrCol(列1) & "列の数値を除外して集計しますか？", vbYesNo, "removeNumberCheck")
Dim numLenX: numLenX = InputBox(getStrCol(列1) & "列の集計対象の文字数を入力してください。" & Chr(10) & Chr(10) & "buf =left(removeNumber(buf),文字数)")
If numLenX = "" Then numLenX = 0
If IsNumeric(numLenX) = False Then errorEnd ("文字数は数値で入力してください。")

Dim rmYflag: rmYflag = 7 - MsgBox(getStrCol(列2) & "列の数値を除外して集計しますか？", vbYesNo, "removeNumberCheck")
Dim numLenY: numLenY = InputBox(Split(Cells(1, 列2).Address(True, False), "$")(0) & "列の集計対象の文字数を入力してください。" & Chr(10) & Chr(10) & "buf =left(removeNumber(buf),文字数)")
If numLenY = "" Then numLenY = 0
If IsNumeric(numLenY) = False Then errorEnd ("文字数は数値で入力してください。")

Dim strFlag As String: strFlag = rmXflag & "," & rmYflag & "," & numLenX & "," & numLenY
Call ◆2列集計dic_main(strFlag)
End Sub

Private Function getStrCol(ColNumber As Long) As String
'列番号を列文字に変換
getStrCol = Split(Cells(1, ColNumber).Address(True, False), "$")(0)
End Function

Sub ◆2列集計dic_main(strFlag As String)
'strFlag = rmXflag,rmYflag,numLenX,numLenY

Dim tictoc As Double
tictoc = Timer

Dim 列1 As Long: 列1 = Selection(1).Column
Dim 列2 As Long: 列2 = getCol2No()

'タイトル行を決定
Dim tGyo As Long: tGyo = 1
If Cells(1, 列1) = "" Then tGyo = Cells(1, 列1).End(xlDown).Row
If Cells(tGyo, 列2) = "" Then errorEnd ("タイトル行不一致")

'最終行を決定
Dim edGyo As Long: edGyo = Cells(Rows.Count, 列1).End(xlUp).Row
If Cells(edGyo, 列2) = "" Then errorEnd ("最終行不一致")

'選択中のセルから出力配列ゲット
Dim oArr: oArr = get2dDicArr(列1, 列2, tGyo, edGyo, strFlag) 'strFlag = rmXflag,rmYflag,numLenX,numLenY

'出力シート名
Dim shName As String: shName = oArr(0, 0): oArr(0, 0) = ""

'転置有無を判断して、セルフォーマットを取得
Dim xFormat As String, yFormat As String
If Cells(tGyo, 列1) & "‡" & Cells(tGyo, 列2) = shName Then '転置なし
xFormat = Cells(tGyo, 列1).Offset(1, 0).NumberFormatLocal
yFormat = Cells(tGyo, 列2).Offset(1, 0).NumberFormatLocal
ElseIf Cells(tGyo, 列2) & "‡" & Cells(tGyo, 列1) = shName Then '転置あり
yFormat = Cells(tGyo, 列1).Offset(1, 0).NumberFormatLocal
xFormat = Cells(tGyo, 列2).Offset(1, 0).NumberFormatLocal
Else
errorEnd ("なんか違う")
End If

Dim Xwth As Double: Xwth = Columns(列1).ColumnWidth
Dim Ywth As Double: Ywth = Columns(列2).ColumnWidth

Application.ScreenUpdating = False

'シート追加
Worksheets.Add

'同名がいなければリネーム
If IsWorksheetExists(shName) = False Then ActiveSheet.Name = shName

'出力先を指定し、列幅、書式を設定
Dim OutPutCell As range: Set OutPutCell = Cells(2, 2) '出力する範囲の左上
Dim oRange As range: Set oRange = OutPutCell.Resize(UBound(oArr, 1), UBound(oArr, 2))
Dim afRange As range: Set afRange = OutPutCell.Resize(UBound(oArr, 1), UBound(oArr, 2) + 1)

oRange.ColumnWidth = Ywth
OutPutCell.ColumnWidth = Xwth

OutPutCell.Resize(UBound(oArr, 1), UBound(oArr, 2)).NumberFormatLocal = "#,##0"
OutPutCell.Resize(UBound(oArr, 1), 1).NumberFormatLocal = xFormat
OutPutCell.Resize(1, UBound(oArr, 2)).NumberFormatLocal = yFormat

'配列をセルに格納
Call ArrayToCell(OutPutCell, oArr)

OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True
afRange.AutoFilter
afRange.CurrentRegion.Borders.LineStyle = xlContinuous

'シート名から項目タイトルを入力
Dim tBuf: tBuf = Split(shName, "‡")
OutPutCell.Offset(-1, 0) = "「" & tBuf(0) & "」×「" & tBuf(1) & "」のピボット(" & ActiveWorkbook.Name & ")"

'印刷レイアウト変更　余白狭いで１枚幅印刷レイアウト
Dim yohakuFlag As Boolean: yohakuFlag = True
Call PrintPageSetup(yohakuFlag)


'レンジを指定して条件付き書式のカラースケールを設定
Dim csRange As range: Set csRange = OutPutCell.Offset(1, 1).Resize(UBound(oArr, 1) - 1, UBound(oArr, 2) - 1)
Call setColorScale(csRange)

'合計の追記
Dim stRow As Long: stRow = csRange(1).Row
Dim stCol As Long: stCol = csRange(1).Column
Dim edRow As Long: edRow = csRange(csRange.Count).Row
Dim edCol As Long: edCol = csRange(csRange.Count).Column
Cells(stRow - 1, edCol + 1) = "合計"

Dim c As Long, r As Long
For r = stRow To edRow
Cells(r, edCol + 1) = WorksheetFunction.Sum(range(Cells(r, stCol), Cells(r, edCol)))
Next r
For c = stCol To edCol + 1
Cells(stRow - 2, c) = WorksheetFunction.Sum(range(Cells(stRow, c), Cells(edRow, c)))
Next c

'列の並べ替え
With ActiveSheet.Sort
.SortFields.Add key:=range(Cells(stRow - 2, stCol), Cells(stRow - 2, edCol)), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
.SetRange range(oRange(1).Offset(-1, 1), oRange(oRange.Count))
.Header = xlNo 'xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With

'行の並べ替え
With ActiveSheet.AutoFilter.Sort
.SortFields.Add key:=range(Cells(stRow, edCol + 1), Cells(edRow, edCol + 1)), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True

If debugFlag Then Debug.Print "ex[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
If debugFlag Then Call シート比較自動試験
End Sub

Sub setColorScale(tarRange As range)
tarRange.FormatConditions.AddColorScale ColorScaleType:=2
tarRange.FormatConditions(tarRange.FormatConditions.Count).SetFirstPriority
tarRange.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
With tarRange.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 16776444
.TintAndShade = 0
End With
tarRange.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValueHighestValue
With tarRange.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
End Sub
Private Function getCol2No()
Dim 列1 As Long: 列1 = Selection(1).Column
Dim 列s As Long: 列s = Selection(Selection.Count).Column '複数セレクション
Dim 列a As Long: 列a = Selection.Areas(Selection.Areas.Count).Column 'エリア
Dim 列2 As Long '選択範囲から２つの列を決定して集計
If 列1 <> 列a Then
列2 = 列a
ElseIf 列1 <> 列s Then
列2 = 列s
Else
errorEnd ("複数列を選択して実行してください。")
End If
getCol2No = 列2
End Function

Function getTimeFlag(sampleRange As range)
Dim timeFlag: timeFlag = 0
If IsNumeric(sampleRange) And InStr(sampleRange.text, ":") > 0 Then '文字列で:を含み、数値型で小数部が０以上
timeFlag = (sampleRange.Value > 0) * (sampleRange.Value - Int(sampleRange.Value) >= 0)
End If
getTimeFlag = timeFlag
End Function

'出力配列を取得　Arr(0,0)はタイトル
Function get2dDicArr(colX As Long, colY As Long, tGyo As Long, edGyo As Long, strFlag As String)
'strFlag = rmXflag,rmYflag,numLenX,numLenY
Dim flagArr: flagArr = Split(strFlag, ",")
Dim numLenX As Long: numLenX = flagArr(2)
Dim numLenY As Long: numLenY = flagArr(3)

'データと書式の確認 X と Y それぞれ
Dim myArrX: myArrX = range(Cells(tGyo, colX), Cells(edGyo, colX)).Value
Dim myArrY: myArrY = range(Cells(tGyo, colY), Cells(edGyo, colY)).Value

'時刻型かを関数で判定
Dim timeFlagX: timeFlagX = getTimeFlag(Cells(tGyo, colX).Offset(1, 0))
Dim timeFlagY: timeFlagY = getTimeFlag(Cells(tGyo, colY).Offset(1, 0))

'出力先のフォーマットを取得
Dim formatX: formatX = Cells(tGyo, colX).Offset(1, 0).NumberFormatLocal
Dim formatY: formatY = Cells(tGyo, colY).Offset(1, 0).NumberFormatLocal

'時刻型は文字列変換処理
Dim i As Long
If timeFlagX > 0 Then
For i = 2 To UBound(myArrX)
myArrX(i, 1) = Format(myArrX(i, 1), formatX)
Next i
End If
If timeFlagY > 0 Then
For i = 2 To UBound(myArrY)
myArrY(i, 1) = Format(myArrY(i, 1), formatY)
Next i
End If

'rmXflag > 0 の場合
If flagArr(0) > 0 Then 'flagArr =[rmXflag,rmYflag,numLenX,numLenY]
For i = 2 To UBound(myArrX)
myArrX(i, 1) = removeNumber(myArrX(i, 1))
Next i
End If
'rmYflag > 0 の場合
If flagArr(1) > 0 Then 'flagArr =[rmXflag,rmYflag,numLenX,numLenY]
For i = 2 To UBound(myArrY)
myArrY(i, 1) = removeNumber(myArrY(i, 1))
Next i
End If

'文字列の絞り込み処理
If numLenX = 0 Then '通常集計の場合
'なにもしない
ElseIf numLenX > 0 Then
For i = 2 To UBound(myArrX)
myArrX(i, 1) = Left(myArrX(i, 1), numLenX)
Next i
ElseIf numLenX < 0 Then
For i = 2 To UBound(myArrX)
myArrX(i, 1) = Right(myArrX(i, 1), Abs(numLenX))
Next i
End If
If numLenY = 0 Then '通常集計の場合
'なにもしない
ElseIf numLenY > 0 Then
For i = 1 To UBound(myArrY)
myArrY(i, 1) = removeNumber(Left(myArrY(i, 1), numLenY))
Next i
ElseIf numLenY < 0 Then
For i = 1 To UBound(myArrY)
myArrY(i, 1) = removeNumber(Right(myArrY(i, 1), Abs(numLenY)))
Next i
End If

'ポインタDic
Dim DicX, DicY, DicZ
Set DicX = CreateObject("Scripting.Dictionary")
Set DicY = CreateObject("Scripting.Dictionary")
Set DicZ = CreateObject("Scripting.Dictionary")

Dim cntX As Long, cntY As Long, cntZ As Long
Dim bufX As String, bufY As String, bufZ As String
For i = 1 To UBound(myArrX)
bufX = myArrX(i, 1)
If Not DicX.exists(bufX) Then
DicX.Add bufX, cntX
cntX = cntX + 1
End If

bufY = myArrY(i, 1)
If Not DicY.exists(bufY) Then
DicY.Add bufY, cntY
cntY = cntY + 1
End If

bufZ = bufX & "‡" & bufY
If Not DicZ.exists(bufZ) Then
DicZ.Add bufZ, 1
Else
DicZ(bufZ) = DicZ(bufZ) + 1
End If
Next i
Set myArrX = Nothing: Set myArrY = Nothing

Dim KeysX: KeysX = DicX.keys
Dim KeysY: KeysY = DicY.keys
Dim KeysZ: KeysZ = DicZ.keys

'要素数から転置判定
Const MaxColumns = 1024 '列上限は16384
Dim trnsFlag As Boolean, msg As String
If DicX.Count > MaxColumns And DicY.Count > MaxColumns Then
errorEnd ("２列ともに要素数が大きすぎます")
ElseIf DicX.Count > MaxColumns Then
trnsFlag = False
ElseIf DicY.Count > MaxColumns Then
trnsFlag = True
ElseIf DicY.Count > DicX.Count Then
msg = "列データ数 ＞ 行データ数 ですが転置しますか？" & Chr(10) _
& KeysY(0) & " : " & DicY.Count & " ＞ " & KeysX(0) & " : " & DicX.Count
If MsgBox(msg, vbYesNo) = vbYes Then
trnsFlag = True
Else
trnsFlag = False
End If
Else
trnsFlag = False
End If

'転置の有無に配慮して、出力配列を作成
Dim buf, oArr()
Dim j As Long, k As Long
If trnsFlag = False Then
ReDim oArr(DicX.Count, DicY.Count)
For i = 1 To UBound(KeysX)
For j = 1 To UBound(KeysY)
oArr(i, j) = 0
Next j
Next i
For i = 1 To UBound(KeysX)
oArr(i, 0) = KeysX(i)
Next i
For j = 1 To UBound(KeysY)
oArr(0, j) = KeysY(j)
Next j
For k = 1 To UBound(KeysZ)
buf = Split(KeysZ(k), "‡")
oArr(DicX(buf(0)), DicY(buf(1))) = DicZ(KeysZ(k))
Next k
oArr(0, 0) = KeysX(0) & "‡" & KeysY(0)
Else
ReDim oArr(DicY.Count, DicX.Count)
For i = 1 To UBound(KeysX)
For j = 1 To UBound(KeysY)
oArr(j, i) = 0
Next j
Next i
For i = 1 To UBound(KeysX)
oArr(0, i) = KeysX(i)
Next i
For j = 1 To UBound(KeysY)
oArr(j, 0) = KeysY(j)
Next j
For k = 1 To UBound(KeysZ)
buf = Split(KeysZ(k), "‡")
oArr(DicY(buf(1)), DicX(buf(0))) = DicZ(KeysZ(k))
Next k
oArr(0, 0) = KeysY(0) & "‡" & KeysX(0)
End If
get2dDicArr = oArr
End Function

Sub ◆1列集計dic_rmNum()

Dim rmXflag: rmXflag = 7 - MsgBox(getStrCol(Selection.Column) & "列の数値を除外して集計しますか？", vbYesNo, "removeNumberCheck")
Dim numLen: numLen = InputBox(Split(Selection.Address(True, False), "$")(0) & "列の集計対象の文字数を入力してください。" & Chr(10) & Chr(10) & "buf =left(removeNumber(buf),文字数)")
If numLen = "" Then numLen = 0

If IsNumeric(numLen) = False Then errorEnd ("文字数は数値で入力してください。")

Dim strFlag As String: strFlag = rmXflag & "," & numLen
Call ◆1列集計dic_main(strFlag)
End Sub

Sub ◆1列集計dic()
Dim strFlag As String: strFlag = 0 & "," & 0
Call ◆1列集計dic_main(strFlag)
End Sub

Sub ◆1列集計dic_main(strFlag As String)

Dim tictoc As Double: tictoc = Timer

Dim col As Long: col = Selection.Column

Dim tGyo As Long: tGyo = 1
If Cells(1, col) = "" Then tGyo = Cells(1, col).End(xlDown).Row 'タイトル行

Dim edGyo As Long: edGyo = Cells(Rows.Count, col).End(xlUp).Row '最終行
If edGyo <= tGyo Then Call errorEnd("データがありません")

'出力配列ゲット
Dim oArr: oArr = get1dDicArr(col, tGyo, edGyo, strFlag)

'データと書式の確認
Dim cWidth As Long: cWidth = Selection.ColumnWidth
Dim formatX: formatX = Cells(tGyo, col).Offset(1, 0).NumberFormatLocal

Application.ScreenUpdating = False

'シート追加
Worksheets.Add
'シート名が重複しなければリネーム
Dim shName As String: shName = oArr(0, 1) & "_内訳"
If IsWorksheetExists(shName) = False Then ActiveSheet.Name = shName

Columns(1).ColumnWidth = 5
Columns(2).ColumnWidth = cWidth

Const タイトル行 = 2
Dim 格納最終行 As Long: 格納最終行 = UBound(oArr, 1) + 1
range("B" & タイトル行 + 1 & ":B" & 格納最終行).NumberFormatLocal = formatX
range("C" & タイトル行 + 1 & ":C" & 格納最終行).NumberFormatLocal = "#,##0"
range("D" & タイトル行 + 1 & ":D" & 格納最終行).NumberFormatLocal = "0.00%"
range("E" & タイトル行 + 1 & ":E" & 格納最終行).Font.Name = "HGP明朝E"

'セルを指定して、oArrを出力
Dim OutPutCell As range: Set OutPutCell = Cells(タイトル行, 1)
Call ArrayToCell(OutPutCell, oArr)

'ウィンドウ枠の固定
OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True

'オートフィルタしてソート
OutPutCell.AutoFilter
With ActiveSheet.AutoFilter.range
.Sort Key1:=.range("C2"), Order1:=xlDescending, Header:=xlYes
.CurrentRegion.Borders.LineStyle = xlContinuous
End With

'配列からセルへ貼り付け
Call ArrayToCell(OutPutCell, oArr, 1)

'欄外に情報を記載
Cells(1, 1) = Format(UBound(oArr) - 1, "#,##0種")
Cells(1, 2).HorizontalAlignment = xlRight
Cells(1, 2) = "合計："
Cells(1, 3) = Format(edGyo - tGyo, "#,##0件")

'印刷レイアウト変更　１枚幅印刷レイアウト
Dim yohakuFlag As Boolean: yohakuFlag = False
Call PrintPageSetup(yohakuFlag)

Application.ScreenUpdating = True
If debugFlag = 1 Then Debug.Print "[" & Now & "] "; "EX" & Format(edGyo - 1, "#,##0行を") & Format(Timer - tictoc, "0.00秒")
If debugFlag Then Call シート比較自動試験
End Sub


'出力配列を取得
Function get1dDicArr(col As Long, tGyo As Long, edGyo As Long, strFlag As String)
Const gLimit = 1000 'ゲージ表示上限
Dim flagArr: flagArr = Split(strFlag, ",") ' rmFlag,numLen

'データと書式の確認
Dim timeFlag: timeFlag = getTimeFlag(Cells(tGyo, col).Offset(1, 0))
Dim formatX: formatX = Cells(tGyo, col).Offset(1, 0).NumberFormatLocal

Dim ColName As String: ColName = Cells(tGyo, col).text '列タイトル
Dim MyArr: MyArr = range(Cells(tGyo + 1, col), Cells(edGyo, col)).Value

Dim i As Long
If timeFlag > 0 Then '時刻型は別扱い
For i = 1 To UBound(MyArr)
MyArr(i, 1) = Format(MyArr(i, 1), formatX)
Next i
End If

If flagArr(0) > 0 Then 'rmNumあり
For i = 1 To UBound(MyArr)
MyArr(i, 1) = removeNumber(MyArr(i, 1))
Next i
End If

If flagArr(1) = 0 Then '通常集計の場合
'なにもしない
ElseIf flagArr(1) > 0 Then
For i = 1 To UBound(MyArr)
MyArr(i, 1) = Left(MyArr(i, 1), flagArr(1))
Next i
ElseIf flagArr(1) < 0 Then
For i = 1 To UBound(MyArr)
MyArr(i, 1) = Right(MyArr(i, 1), Abs(flagArr(1)))
Next i
End If

Dim buf As String
Dim dic: Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(MyArr)
buf = MyArr(i, 1)
If Not dic.exists(buf) Then
dic.Add buf, 1
Else
dic(buf) = dic(buf) + 1
End If
Next i

''出力
Dim oArr() As Variant: ReDim oArr(dic.Count + 1, 4)

oArr(0, 0) = "№"
oArr(0, 1) = ColName
oArr(0, 2) = "件"
oArr(0, 3) = "割合"
oArr(0, 4) = "ゲージ"
Const ゲージ文字 = "|"

Dim keys: keys = dic.keys
If dic.Count < gLimit Then
For i = 0 To dic.Count - 1
oArr(i + 1, 0) = i + 1
oArr(i + 1, 1) = keys(i)
oArr(i + 1, 2) = dic(keys(i))
oArr(i + 1, 3) = dic(keys(i)) / (edGyo - tGyo)
oArr(i + 1, 4) = Application.WorksheetFunction.Rept(ゲージ文字, dic(keys(i)) * dic.Count / (edGyo - tGyo) * 1 \ 1)
Next i
Else '件数が多い場合はゲージを出さない
For i = 0 To dic.Count - 1
oArr(i + 1, 0) = i + 1
oArr(i + 1, 1) = keys(i)
oArr(i + 1, 2) = dic(keys(i))
Next i
End If
Set dic = Nothing
get1dDicArr = oArr
End Function


Function removeNumber(inputStr)
Dim i As Long
For i = 0 To 9
inputStr = Replace(inputStr, i, "")
Next i
removeNumber = inputStr
End Function

Private Sub PrintPageSetup(Optional yohakuFlag As Boolean = False)

'印刷レイアウト変更　余白狭いで１枚幅印刷レイアウト
With ActiveSheet.PageSetup
Application.PrintCommunication = False
.PrintTitleRows = "$2:$2"
.CenterHorizontally = True '中央寄せに
If yohakuFlag Then '余白変更ありの場合
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
End If
.FitToPagesWide = 1 '横何ページ分で収めるか
.FitToPagesTall = 0 '自動は０。指定しないと１になる。
.RightHeader = "&D"
.CenterFooter = "&P/&N"
Application.PrintCommunication = True
End With
End Sub

'2次元配列をシートに貼り付ける便利モジュール
Sub ArrayToCell(Target As range, oArr, Optional ColCnt As Long = 0)
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数

'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub

Private Function IsWorksheetExists(シート名 As String) As Boolean 'シートループで同じシート名があるかチェック　あればTrue
Dim WS As Worksheet, flag As Boolean
For Each WS In Worksheets
If WS.Name = シート名 Then flag = True '開いたファイルに目的の名前のシートがあるか？
Next WS
IsWorksheetExists = flag
End Function

'エラー発生時にメッセージを出力して終了させる
Private Sub errorEnd(msg)
Application.ScreenUpdating = True 'おまじない
MsgBox msg
End
End Sub