| |
こなのでは？
表Aは、「開始日」がA列、「終了日」がB列で1行目に列見出しが有とします
表Bは、A列1行目に「基準日」の行見出しが有る物とします
集計用テーブル（ハッシュテーブル）を作成して集計します
（ハッシュテーブル = 日付と配列の添え字を関連付けた配列変数）
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntMax As Variant
Dim vntMin As Variant
Dim vntTable As Variant
Dim lngDay As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("表A").Cells(1, "A")
'◆結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("表B").Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'「開始日」A列、「終了日」B列データを配列に取得
vntData = .Offset(1).Resize(lngRows, 2).Value
'「開始日」列、「終了日」列から最小最大の日付を取得
vntMax = Application.WorksheetFunction.Max(.Offset(1).Resize(lngRows, 2))
vntMin = Application.WorksheetFunction.Min(.Offset(1).Resize(lngRows, 2))
End With
'集計用テーブルを作成
ReDim vntTable(1, vntMax - vntMin)
'日付を上から下に繰り返し
For i = 1 To lngRows
'「開始日」が空白で無いなら
If vntData(i, 1) <> "" Then
'ハッシュ値を計算
lngDay = vntData(i, 1) - vntMin
'ハッシュの位置に集計
vntTable(0, lngDay) = vntTable(0, lngDay) + 1
End If
'「終了日」が空白で無いなら
If vntData(i, 2) <> "" Then
'ハッシュ値を計算
lngDay = vntData(i, 2) - vntMin
'ハッシュの位置に集計
vntTable(1, lngDay) = vntTable(1, lngDay) + 1
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
With rngResult
'データをクリア
.Parent.UsedRange.ClearContents
'結果を出力
.Offset(1, 1).Resize(2, UBound(vntTable, 2) + 1).Value = vntTable
'行見出しを出力
For i = 1 To 3
.Offset(i - 1).Value = Choose(i, "基準日", "開始日", "終了日")
Next i
'基準日を出力
ReDim vntTable(vntMax - vntMin)
For i = 0 To vntMax - vntMin
vntTable(i) = vntMin + i
Next i
With .Offset(, 1).Resize(, UBound(vntTable) + 1)
.NumberFormat = "m/d"
.Value = vntTable
End With
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
