Attribute VB_Name = "操作系モジュール"
Option Explicit '変数を先に宣言しなさいよ
Const debugFlag = 0


'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, Xwth As Double, Ywth As Double
    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
        Xwth = Columns(列1).ColumnWidth
        Ywth = Columns(列2).ColumnWidth
    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
        Xwth = Columns(列2).ColumnWidth
        Ywth = Columns(列1).ColumnWidth
    Else
        errorEnd ("なんか違う")
    End If

    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 ◆2列集計結果の再ソート()
    
    '件数範囲 左上と右下
    Dim stRow As Long: stRow = 3
    Dim stCol As Long: stCol = 3
    Dim edRow As Long: edRow = Cells(Rows.Count, 2).End(xlUp).Row
    Dim edCol As Long: edCol = Cells(2, Columns.Count).End(xlToLeft).Column - 1
    
    'タイトル抽出
    Dim strBuf: strBuf = Split(Cells(1, "B"), "×")
    Dim strX As String: strX = strBuf(0)
    Dim strY As String: strY = strBuf(1):    strY = Left(strY, InStr(strY, "」"))
    
    Dim RC As Long, msg As String
    
   'y軸用メッセージを出して、ソート
    msg = "y軸" & strY & "を昇順に再ソートします。" & Chr(10) & "はい：項目昇順　、　いいえ：カウント降順" '●
    RC = MsgBox(msg, vbYesNoCancel)
    
    Dim vOrder As Long   '並び順 XY共通
    Dim rOffset As Long 'Keyの位置
    
    If RC = vbYes Then  '昇順
        vOrder = xlAscending '1:昇順
        rOffset = 1
    ElseIf RC = vbNo Then   '降順
        vOrder = xlDescending  '  2:降順
        rOffset = 2
    End If
    
    Dim keyRange As range, tarRange As range
        
    '列の並べ替え はソートオブジェクト
    If RC <> vbCancel Then
        Set keyRange = range(Cells(stRow - rOffset, stCol), Cells(stRow - rOffset, edCol))
        Set tarRange = range(Cells(stRow - 2, stCol), Cells(edRow, edCol))
        
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add key:=keyRange, SortOn:=xlSortOnValues, Order:=vOrder, DataOption:=xlSortNormal
            .SetRange tarRange
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
    End If

   'x軸用メッセージを出して、ソート
    msg = "x軸" & strX & "を昇順に再ソートします。" & Chr(10) & "はい：項目昇順　、　いいえ：カウント降順" '●
    RC = MsgBox(msg, vbYesNoCancel)
    'xはオートフィルタ範囲をソートなのでレンジ設定は要らない
    
    Dim keyCol As Long
    If RC = vbYes Then  '昇順
        vOrder = xlAscending '1   既定値。昇順に並べ替えます
        keyCol = 2
    ElseIf RC = vbNo Then   '降順
        vOrder = xlDescending  '  2   降順に並べ替えます
        keyCol = edCol + 1
    End If
    
    '行の並べ替え はオートフィルタオブジェクト
    If RC <> vbCancel Then
        Set keyRange = range(Cells(stRow, keyCol), Cells(edRow, keyCol))
        With ActiveSheet.AutoFilter.Sort
            .SortFields.Clear
            .SortFields.Add key:=keyRange, SortOn:=xlSortOnValues, Order:=vOrder, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
        
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 = IfError(myArrX(i, 1), "#エラー")
        If Not DicX.exists(bufX) Then
            DicX.Add bufX, cntX
            cntX = cntX + 1
        End If
        
        bufY = IfError(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


'col列のtGyoからedGyoのを解析し、出力配列を取得　strFlagはオプション
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 myRange As range: Set myRange = range(Cells(tGyo + 1, col), Cells(edGyo, col)).SpecialCells(xlCellTypeVisible)
    Dim myArr: myArr = range(Cells(tGyo + 1, col), Cells(edGyo, col)).SpecialCells(xlCellTypeVisible).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 = IfError(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

'0-9の文字を除去
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


Sub 集計用列を挿入()
    Dim col As Long: col = Selection.Column
    Dim strCol As String: strCol = getStrCol(col)
    
    Dim tGyo As Long: tGyo = 1
    If Cells(tGyo, col) = "" Then tGyo = Cells(tGyo, col).End(xlDown).Row
    Dim edGyo As Long: edGyo = Cells(Rows.Count, col).End(xlUp).Row
    
    Dim myRange As range: Set myRange = range(Cells(tGyo, col), Cells(edGyo, col))
    Dim myArr: myArr = myRange.value
        
    Dim RC As Long: RC = MsgBox(strCol & "列の集計用列を追加します。数値を無視しますか？", vbYesNoCancel)
    If RC = vbCancel Then End
 
    Dim i As Long, n As Long, tStr As String
    If RC = vbYes Then
        For i = 1 To UBound(myArr)
            For n = 0 To 9
                myArr(i, 1) = Replace(myArr(i, 1), n, "")
            Next n
        Next i
        tStr = "_rmNum"
    End If
    
    Dim inputMsg As String: inputMsg = "抽出文字数 Nを入力してください。" & Chr(10) & "+の場合：Left（N)　　-の場合：Right（N)"
    Dim strLen: strLen = InputBox(inputMsg, "抽出文字数入力")
    If strLen = "" Then strLen = 0
    If IsNumeric(strLen) = False Then Call errorEnd("0以外の数値を入力してください")
    If strLen > 0 Then
        For i = 1 To UBound(myArr)
            myArr(i, 1) = Left(myArr(i, 1), strLen)
        Next i
        tStr = tStr & "_Left" & strLen
    ElseIf strLen < 0 Then
        For i = 1 To UBound(myArr)
            myArr(i, 1) = Right(myArr(i, 1), Abs(strLen))
        Next i
        tStr = tStr & "_right" & Abs(strLen)
    End If

    Selection.EntireColumn.Offset(0, 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    myRange.Offset(0, 1).NumberFormatLocal = Cells(tGyo + 1, col).NumberFormatLocal
    myRange.Offset(0, 1).value = myArr
    Cells(tGyo, col + 1) = Cells(tGyo, col).value & tStr
End Sub

Private Function IfError(値, エラーの場合の値)
    If IsError(値) Then
        IfError = エラーの場合の値
    Else
        IfError = 値
    End If
End Function

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