趣味プログラミングblog

---

Sub ◆1列集計dic_EX()

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 edGyo As Long: edGyo = Cells(Rows.Count, col).End(xlUp).Row '最終行
If edGyo = 1 Then Call errorEnd("データがありません")

Dim ColName As String: ColName = Cells(tGyo, col).text '列タイトル
Dim MyArray: MyArray = range(Cells(tGyo + 1, col), Cells(edGyo, col)).Value
Dim sampleRange As range: Set sampleRange = Cells(tGyo, col).Offset(1, 0)
Dim formatX: formatX = sampleRange.NumberFormatLocal
Dim cFlag: cFlag = InStr(sampleRange.text, ":")
Dim timeFlag: timeFlag = 0
If IsNumeric(sampleRange) And cFlag > 0 Then '文字列で:を含み、数値型で小数部が０以上
timeFlag = (sampleRange.Value > 0) * (sampleRange.Value - Int(sampleRange.Value) >= 0)
End If
' Stop
'辞書配列に格納
Dim dic, i As Long, buf As String, keys
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(MyArray)
If timeFlag > 0 Then '時刻型は別扱い
buf = CDate(MyArray(i, 1))
Else
buf = MyArray(i, 1)
End If
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)) / (edGyo - tGyo)
oArr(i + 1, 4) = Application.WorksheetFunction.Rept(ゲージ文字, dic(keys(i)) * dic.Count / (edGyo - 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("B" & タイトル行 + 1 & ":B" & 格納最終行).NumberFormatLocal = formatX
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(edGyo - tGyo, "#,##0件")

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


Sub シート比較自動試験()
Const refSHname = "ref" '比較対象シート名
If ActiveSheet.Name = refSHname Then msgEnd ("他のシートを選択して実行してください。")

'refSHnameシートがあるか判定
Dim sh As Long, rWS As Worksheet, tWS As Worksheet
For sh = 1 To Worksheets.Count
If Worksheets(sh).Name = refSHname Then
Set rWS = Worksheets(sh)
Set tWS = ActiveSheet
End If
Next sh

'２シート選択されてるか判定
If ActiveWindow.SelectedSheets.Count = 2 Then
Set rWS = ActiveWindow.SelectedSheets(1) '比較対象
Set tWS = ActiveWindow.SelectedSheets(2) 'test対象
ElseIf rWS Is Nothing Then
msgEnd ("２シート選択するか比較対象シート名を「 " & refSHname & " 」に変更してください。")
End If

'UsedRange比較と値の比較をして、結果を出力メッセージ用変数に格納
Dim uRangeDiff As Boolean, r As Variant, rValue As String, vCnt As Long, tCnt As Long, rMsg As String, tMsg As String
If tWS.UsedRange.Address <> rWS.UsedRange.Address Then
uRangeDiff = True
rMsg = "UsedRangeが異なります。" & Chr(10)
rMsg = rMsg & Chr(10)
rMsg = rMsg & tWS.Name & " 　 " & rWS.Name & Chr(10)
rMsg = rMsg & "[" & Replace(tWS.UsedRange.Address & "] ⇔ [" & rWS.UsedRange.Address, "$", "") & "]"
Else
For Each r In tWS.UsedRange
If tWS.range(r.Address).Value <> rWS.range(r.Address).Value Then
vCnt = vCnt + 1
If vCnt < 20 Then
rMsg = rMsg & Chr(10) & Replace(r.Address, "$", "") & " [" & rWS.range(r.Address).Value & "] ⇔ [" & tWS.range(r.Address).Value & "]"
ElseIf vCnt = 20 Then
rMsg = rMsg & Chr(10) & "以下省略"
End If
End If
If tWS.range(r.Address).text <> rWS.range(r.Address).text Then
tCnt = tCnt + 1
If tCnt < 20 Then
tMsg = tMsg & Chr(10) & Replace(r.Address, "$", "") & " [" & rWS.range(r.Address).text & "] ⇔ [" & tWS.range(r.Address).text & "]"
ElseIf tCnt = 20 Then
tMsg = tMsg & Chr(10) & "以下省略"
End If
End If
Next r
End If

'結果表示
If uRangeDiff = True Then
MsgBox rMsg, vbOKOnly, "範囲エラー"
Exit Sub
End If
If vCnt > 0 Then MsgBox ("値ベースで" & vCnt & "箇所違います" & Chr(10) & Chr(10) & "セル　 " & rWS.Name & " 　 " & tWS.Name & rMsg), vbOKOnly, "値エラー"
If tCnt > 0 Then MsgBox ("表示ベースで" & tCnt & "箇所違います" & Chr(10) & Chr(10) & "セル　 " & rWS.Name & " 　 " & tWS.Name & tMsg), vbOKOnly, "表示エラー"
If vCnt + tCnt = 0 Then
Dim msg As String: msg = rWS.Name & "と" & tWS.Name & "に相違点はありません。"
MsgBox msg
End If
Application.DisplayAlerts = False
If MsgBox("結果シートを削除しますか？", vbYesNo, "シート削除確認") = vbYes Then ActiveSheet.Delete
Application.DisplayAlerts = False
End Sub

Private Sub msgEnd(msg)
'メッセージを出して処理終了
MsgBox msg
End 'exit subじゃない
End Sub