備忘3 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
Author And Source
この問題について(備忘3 4H070V), 我々は、より多くの情報をここで見つけました https://qiita.com/noob_turkey/items/ce5b0b5fef9a1c74f065著者帰属:元の著者の情報は、元のURLに含まれています。著作権は原作者に属する。
Content is automatically searched and collected through network algorithms . If there is a violation . Please contact us . We will adjust (correct author information ,or delete content ) as soon as possible .