| |
データ的にはそんなに多く無いのでしょうから？
別なシートに集計表を作ったら？
元のデータは、Sheet1に在るとします、先頭行は列見出しとします
結果はSheet2に出力されます
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngColumn As Long
Dim lngColumns As Long
Dim rngResult As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim lngMax As Long
Dim lngMin As Long
Dim dicIndex As Object
Dim lngTop As Long
Dim lngCount As Long
Dim strProm As String
'結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1").UsedRange
'日付の最小値、最大値を取得
lngMin = Application.WorksheetFunction.Min(.Resize(, 1))
lngMax = Application.WorksheetFunction.Max(.Resize(, 1))
'行数、列数を取得
lngRows = .Rows.Count
lngColumns = .Columns.Count
'結果用配列を確保
ReDim vntResult(lngMax - lngMin + 1, 0)
'配列の0列目に日付を記入
For i = 1 To lngMax - lngMin + 1
vntResult(i, 0) = i + lngMin - 1
Next i
'Listのデータ先頭〜最終まで繰り返し
For i = 2 To lngRows
'Listから1行分配列に取得
vntData = .Cells(i, 1).Resize(, lngColumns).Value
'配列の2列目〜最終列まで繰り返し
For j = 2 To lngColumns
'値がEmptyならForを脱出
If IsEmpty(vntData(1, j)) Then
Exit For
End If
'Dictionaryに登録が無い場合
If Not dicIndex.Exists(vntData(1, j)) Then
'登録番号を発番
lngColumn = lngColumn + 1
'Dictionaryにナンバーを登録
dicIndex.Item(vntData(1, j)) = lngColumn
'結果配列を拡張して、発番した列位置の
'先頭行にナンバーをを書き込み
ReDim Preserve vntResult(lngMax - lngMin + 1, lngColumn)
vntResult(0, lngColumn) = vntData(1, j)
End If
'配列の日付行の該当番号位置に"*"を書き込み
vntResult(CLng(vntData(1, 1)) - lngMin + 1, _
dicIndex.Item(vntData(1, j))) = "*"
Next j
Next i
End With
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
With rngResult
.Parent.Cells.ClearContents
'日付書式を設定
.Resize(, UBound(vntResult, 1) + 1).NumberFormat = "m/d"
'結果を出力
.Resize(UBound(vntResult, 2) + 1, UBound(vntResult, 1) + 1).Value _
= Application.Transpose(vntResult)
'連続して三日以上の場合、BuckColorを変更
For i = 1 To UBound(vntResult, 2)
lngTop = 0
lngCount = 0
For j = 1 To UBound(vntResult, 1)
If vntResult(j, i) <> "" Then
If lngTop = 0 Then
lngTop = j
lngCount = 1
Else
lngCount = lngCount + 1
End If
Else
If lngCount >= 3 Then
.Offset(i, lngTop).Resize(, lngCount).Interior.ColorIndex = 34
End If
lngTop = 0
lngCount = 1
End If
Next j
If lngCount >= 3 Then
.Offset(i, lngTop).Resize(, lngCount).Interior.ColorIndex = 34
End If
Next i
.Parent.Columns.AutoFit
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/1/20(水) 20:21 -
