備忘３ 4H070V

Sub Sample3()

'集計
Dim Dic, Dic2, Dic3, Dic4, Dic5, Dic6, i As Long, buf As String
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
    buf = Cells(i, 4).Value
    If Not Dic.Exists(buf) Then
        Dic.Add buf, 1
        Dic2.Add buf, 0
    Else
        Dic.Item(buf) = CLng(Dic.Item(buf)) + 1
    End If
    buf = Cells(i, 5).Value
    If Not Dic.Exists(buf) Then
        Dic.Add buf, 0
        Dic2.Add buf, 1
    Else
        If Not Dic2.Exists(buf) Then
        Else
            Dic2.Item(buf) = CLng(Dic2.Item(buf)) + 1
        End If
    End If
Next i

'データシートを追加
Dim OldSheet As Worksheet
Set OldSheet = ActiveSheet
Dim OSN As String
ODN = OldSheet.Name

Dim NewWorkSheet As Worksheet
Set NewWorkSheet = Worksheets.Add()
NewWorkSheet.Name = ODN & "_DATA"


'集計結果出力
Columns("A:F").Clear
Cells(1, 1).Value = "日付"
Cells(1, 2).Value = "予定数"
Cells(1, 3).Value = "実績"
Cells(1, 4).Value = "計画線"
Cells(1, 5).Value = "実績線"
Cells(1, 6).Value = "理想線"

i = Dic.Count
With Application
Cells(2, 1).Resize(i).NumberFormatLocal = "m""月""d""日"";@"
Cells(2, 1).Resize(i).Value = .Transpose(Dic.keys)
Cells(2, 2).Resize(i).Value = .Transpose(Dic.items)
End With
Set Dic = Nothing

i = Dic2.Count
With Application
Cells(2, 3).Resize(i).Value = .Transpose(Dic2.items)
End With
Set Dic2 = Nothing

'空白削除
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    If ActiveSheet.Cells(i, 1) = "" Then
        'A列が空白なら行削除
        Application.Rows(i).Delete
    End If
Next

'元シートをアクティブに
OldSheet.Activate

End Sub