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