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

Sub ◆2列集計dic()
    Dim tictoc As Double
    tictoc = Timer
    
    Dim 列1 As Long, 列2 As Long
    列1 = Selection(1).Column
    列2 = 列2nd(列1)    '選択範囲から２つの列を決定して集計
    
    Dim Xwth As Double: Xwth = Columns(列1).ColumnWidth
    Dim Ywth As Double: Ywth = Columns(列2).ColumnWidth

    Dim DicX, DicY, DicZ
    Set DicX = CreateObject("Scripting.Dictionary")
    Set DicY = CreateObject("Scripting.Dictionary")
    Set DicZ = CreateObject("Scripting.Dictionary")
    
    Call cntDic(DicX, 列1, DicY, 列2, DicZ)
    
    Dim buf, oArr()
    ReDim oArr(DicX.Count, DicY.Count)
    
    Dim i As Long, j As Long, k As Long, KeysX, KeysY, KeysZ
    KeysX = DicX.keys:     KeysY = DicY.keys:     KeysZ = DicZ.keys

    '0埋めしておく
    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
    
    Dim trnsFlag As Boolean
    If UBound(KeysX) > 256 And UBound(KeysY) > 256 Then
        MsgBox "２列ともに要素数が大きすぎます"
        Exit Sub
    ElseIf UBound(KeysX) > 256 Then
        trnsFlag = False
    ElseIf UBound(KeysY) > 256 Then
        trnsFlag = True
    ElseIf UBound(KeysY) > UBound(KeysX) Then
        
        If MsgBox("列データ数 ＞ 行データ数 ですが転置しますか？" & Chr(10) _
                & KeysY(0) & " : " & DicY.Count & " ＞ " & KeysX(0) & " : " & DicX.Count, vbYesNo) = vbYes Then
            trnsFlag = True
        Else
            trnsFlag = False
        End If
    Else
        trnsFlag = False
    End If
    'シート追加
    Worksheets.Add
    
    Dim OutPutCell As range, oRange As range
    Set OutPutCell = Cells(2, 2)
    
    If trnsFlag = False Then
        Set oRange = OutPutCell.Resize(DicX.Count, DicY.Count)
        oRange.ColumnWidth = Ywth
        OutPutCell.ColumnWidth = Xwth
        Call ArrayToCell(OutPutCell, oArr)
        ActiveSheet.Name = KeysX(0) & "‡" & KeysY(0)
    Else
        Set oRange = OutPutCell.Resize(DicY.Count, DicX.Count)
        oRange.ColumnWidth = Xwth
        OutPutCell.ColumnWidth = Ywth
        Call ArrayToCell_trns(OutPutCell, oArr)
        ActiveSheet.Name = KeysY(0) & "‡" & KeysX(0)
    End If
    OutPutCell.Offset(1, 1).Select
    ActiveWindow.FreezePanes = True
    oRange.AutoFilter
    oRange.CurrentRegion.Borders.LineStyle = xlContinuous
    
    OutPutCell.Offset(-1, 0) = "「" & KeysX(0) & "」×「" & KeysY(0) & "」のピボット(" & ActiveWorkbook.Name & ")"
    
    With ActiveSheet.PageSetup  '余白狭いで１枚幅印刷レイアウト
        Application.PrintCommunication = False
        .PrintTitleRows = "$1:$2"
        .PrintTitleColumns = ""
        .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)
        .FitToPagesWide = 1
        .FitToPagesTall = 0 '自動は０。指定しないと１になる。
        Application.PrintCommunication = True
    End With
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")

End Sub

Private Sub cntDic(ByRef DicX, ColX As Long, ByRef DicY, ColY As Long, ByRef DicZ)
    
    Dim tGyo As Long
    If Cells(1, ColX) <> "" Then
        tGyo = 1
    Else
        tGyo = Cells(1, ColX).End(xlDown).Row
    End If
    If Cells(tGyo, ColY) = "" Then
        Debug.Print "タイトル行不一致"
        Exit Sub
    End If
    
    Dim GyoEnd As Long
    GyoEnd = Cells(Rows.Count, ColX).End(xlUp).Row
    If Cells(GyoEnd, ColY) = "" Then
        Debug.Print "最終行不一致"
        Exit Sub
    End If
    
    Dim z() As String
    ReDim z(GyoEnd - tGyo)
    
    'ポインタDic
    Dim i As Long, cntX As Long, cntY As Long
    Dim bufX As String, bufY As String, bufZ As String
    
    For i = tGyo To GyoEnd
        bufX = Cells(i, ColX).Value
        If Not DicX.exists(bufX) Then
            DicX.Add bufX, cntX
            cntX = cntX + 1
        End If
        
        bufY = Cells(i, ColY).Value
        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
End Sub


Sub ◆1列集計dic()
    
    Dim tictoc As Double:    tictoc = Timer

    Dim cWidth As Long: cWidth = Selection.ColumnWidth
    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 GyoEnd As Long:    GyoEnd = Cells(Rows.Count, col).End(xlUp).Row    '最終行
    If GyoEnd = 1 Then Call errorEnd("データがありません")
    
    Dim ColName As String: ColName = Cells(tGyo, col).text  '列タイトル

    '辞書配列に格納
    Dim dic, i As Long, buf As String, keys
    Set dic = CreateObject("Scripting.Dictionary")
    For i = tGyo + 1 To GyoEnd
        buf = Cells(i, col).text
        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 ゲージ文字 = "|"
        
    keys = dic.keys
    If dic.Count < 1000 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)) / (GyoEnd - tGyo)
            oArr(i + 1, 4) = Application.WorksheetFunction.Rept(ゲージ文字, dic(keys(i)) * dic.Count / (GyoEnd - tGyo) \ 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
    
    Dim 格納最終行 As Long: 格納最終行 = dic.Count + 2
    Set dic = Nothing
    
    'シート追加
    Worksheets.Add
    
    Const タイトル行 = 2

    Columns(1).ColumnWidth = 5
    Columns(2).ColumnWidth = cWidth
    
    range("E" & タイトル行 + 1 & ":E" & 格納最終行).Font.Name = "HGP明朝E"
    range(Cells(タイトル行 + 1, 3), Cells(格納最終行, 3)).NumberFormatLocal = "#,##0"
    range(Cells(タイトル行 + 1, 4), Cells(格納最終行, 4)).NumberFormatLocal = "0.00%"

    
    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)
    
    On Error Resume Next
    ActiveSheet.Name = ColName & "_内訳"
    
    '欄外に情報を記載
    Cells(1, 1) = Format(i, "#,##0種")
    Cells(1, 2).HorizontalAlignment = xlRight
    Cells(1, 2) = "合計："
    Cells(1, 3) = Format(GyoEnd - tGyo, "#,##0件")
    
Debug.Print "[" & Now & "] "; Format(GyoEnd - 1, "#,##0行を") & Format(Timer - tictoc, "0.00秒")
If debugFlag Then Call シート比較自動試験
End Sub


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

Sub ArrayToCell_trns(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(ColCnt, iRowMax).Value = WorksheetFunction.Transpose(oArr)
    Else
        Target.Resize(iColMax, iRowMax).Value = WorksheetFunction.Transpose(oArr)
    End If
End Sub
Function 列2nd(列1) '◆2列集計dic()
    Dim 列s As Long, 列a As Long
    列s = Selection(Selection.Count).Column '複数セレクション
    列a = Selection.Areas(Selection.Areas.Count).Column 'エリア
    If 列1 <> 列a Then
        列2nd = 列a
    ElseIf 列1 <> Selection(Selection.Count).Column Then
        列2nd = 列s
    Else
        列2nd = 列1
    End If

End Function

Private Sub errorEnd(msg)
    MsgBox msg
    End
End Sub