趣味プログラミングblog

---

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