Sub CreateGraphWithFilteredXAxis()
Dim ws As Worksheet
Dim lastRow As Long
Dim uniqueDates As Collection
Dim dateCounts As Object
Dim rng As Range
Dim chartObj As ChartObject
Dim i As Long
Dim dataRange As Range
Dim displayInterval As Long ‘ ラベルの表示間隔
Dim tempDate As Date
‘ 作業するシートを取得
Set ws = ThisWorkbook.Sheets(1) ‘ 必要に応じてシート名を変更してください
‘ F列の最終行を取得
lastRow = ws.Cells(ws.Rows.Count, “F”).End(xlUp).Row
If lastRow < 1 Then
MsgBox "F列にデータがありません。", vbExclamation
Exit Sub
End If
' ユニークな日付を収集し、個数をカウント
Set uniqueDates = New Collection
Set dateCounts = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each rng In ws.Range("F1:F" & lastRow)
If IsDate(rng.Value) Then
tempDate = CDate(rng.Value)
' 日付が1900年1月1日以降であるかを確認
If tempDate >= DateSerial(1900, 1, 1) Then
uniqueDates.Add tempDate, CStr(tempDate) ‘ 重複を防止
dateCounts(CStr(tempDate)) = dateCounts(CStr(tempDate)) + 1
End If
End If
Next rng
On Error GoTo 0
‘ ユニークな日付がない場合は終了
If uniqueDates.Count = 0 Then
MsgBox “F列に有効な日付がありません。”, vbExclamation
Exit Sub
End If
‘ 結果をG列とH列に書き込む
ws.Range(“G:H”).ClearContents ‘ G列とH列をクリア
ws.Cells(1, “G”).Value = “日付”
ws.Cells(1, “H”).Value = “個数”
For i = 1 To uniqueDates.Count
ws.Cells(i + 1, “G”).Value = uniqueDates(i)
ws.Cells(i + 1, “H”).Value = dateCounts(CStr(uniqueDates(i)))
Next i
‘ G列とH列を昇順に並べ替える
Set dataRange = ws.Range(“G1:H” & uniqueDates.Count + 1)
dataRange.Sort Key1:=ws.Range(“G2”), Order1:=xlAscending, Header:=xlYes
‘ X軸のラベル間引き間隔を設定
If uniqueDates.Count > 30 Then
displayInterval = WorksheetFunction.RoundUp(uniqueDates.Count / 30, 0) ‘ 最大30個表示
Else
displayInterval = 1
End If
‘ グラフの作成
On Error Resume Next
Set chartObj = ws.ChartObjects(“DateCountChart”)
On Error GoTo 0
If Not chartObj Is Nothing Then chartObj.Delete ‘ 既存のグラフを削除
Set chartObj = ws.ChartObjects.Add(Left:=300, Width:=800, Top:=50, Height:=400)
With chartObj.Chart
.ChartType = xlColumnClustered
.SetSourceData Source:=ws.Range(“G1:H” & uniqueDates.Count + 1)
.HasTitle = True
.ChartTitle.Text = “日付ごとのデータ個数”
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Text = “日付”
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Text = “個数”
‘ X軸ラベルの間引き設定
With .Axes(xlCategory)
.TickLabels.NumberFormat = “yyyy/mm/dd”
.TickLabelSpacing = displayInterval
End With
End With
MsgBox “グラフを作成しました。”, vbInformation
End Sub
