Excel のマクロで集計を行うサンプルです(コード埋め込み)
内容
厚生労働省から公開されているコロナの統計データ(県別・日別の発生件数)を読み込み
県別・月別に集計して結果を表示します
厚生労働省の統計データの最新版(日々更新)を読み込ませてもOKです
↓
※地方別(関東・東北など)の集計も行っています
次のバージョンでは、結果表示の選択(表形式/グラフ形式)ができるようにする予定
使用方法
1.以下のファイルをローカルにダウンロード
・集計サンプル-Ver2.5累計 ←動かすマクロが入ったExcel
・統計データ8月22日 ← 2021年8月22日のデータ
・統計データ9月8日 ← 2021年9月8日のデータ
※共有
2.集計サンプル-Ver2.5累計を開く
3.集計メインシートの 「取り込み・集計開始」ボタンを押す
読み込むデータとして、ダウンロードした8月22日のデータを指定して読み込みます
PCのスペックにもよりますが、初回(27,504件)の処理に10～20秒)
県別に集計した結果が表示されます
4.新しい統計データの読み込み
3.の処理を終えた状態で9月8日のデータを読み込みます
注 デフォルトで直近120日分のデータを更新(D2の値を変更すれば期間を伸ばせます)
前回の取り込み以降に差異が発生している県と月は赤で表示されます
5.集計シートから取り込んだデータを消したいときは「集計シート初期化」ボタンを押します
Option Explicit
Type AddressType
RecipType As String
SMTPAddress As String
Alias As String
Name As String
External As Boolean
End Type
Public MyDomainList() As Variant
Sub ScheduleGet()
'Outlook定義
Dim OlApp As Outlook.Application
Dim OlNS As Outlook.Namespace
Dim OlFolder As Folder
Dim OlItems As Outlook.Items
Dim OlItem As AppointmentItem
Dim OlRecips As Object
'Excel定義
Dim CurrentBook As Workbook
Dim CurrentSheet As Worksheet
Dim EmailAddress As String
Dim ExcUser As Object
Dim ExcDL As Object
Dim AddressArry() As AddressType
Dim AccountCnt As Long
Dim ExternalCnt As Long
Dim i As Long
Dim LoopCount As Long
Dim TextBuff As String
'範囲指定
Dim SelectStartDate As Date
Dim SelectEndDate As Date
'制御用
MyDomainList() = Array("gmail.com", "aairoiro.com")
SelectStartDate = "2021/10/01"
SelectEndDate = "2021/10/15"
'更新抑制
Application.ScreenUpdating = False
'BookとSheetの設定
Set CurrentBook = ActiveWorkbook
Set CurrentSheet = CurrentBook.Sheets("スケジュール")
'タイトルを記述
With CurrentSheet
.Range("A1").CurrentRegion.ClearContents
.Range("A1").Value = "主催者"
.Range("B1").Value = "件名"
.Range("C1").Value = "日付"
.Range("D1").Value = "開始時間"
.Range("E1").Value = "終了時間"
.Range("F1").Value = "必須出席者"
.Range("G1").Value = "ID"
.Range("H1").Value = "種類"
.Range("I1").Value = "操作"
.Range("J1").Value = "取り込み結果"
With .Range("A1:Z1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
CurrentSheet.Activate
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得
Set OlApp = New Outlook.Application
Set OlNS = OlApp.GetNamespace("MAPI")
Set OlFolder = OlNS.GetDefaultFolder(olFolderCalendar)
Set OlItems = OlFolder.Items
'開始日の降順に並び変える
OlItems.Sort "[開始日]", True
LoopCount = 2
For Each OlItem In OlItems
If TypeName(OlItem) = "AppointmentItem" Then
With OlItem
If .Start >= SelectStartDate And .Start <= SelectEndDate Then
'受信者情報を取り出す
AccountCnt = .Recipients.Count
Set OlRecips = .Recipients
'Emailaddress取得、外部チェック、ユーザー名取得
Call SmtpAddressGet(OlRecips, AccountCnt, AddressArry(), ExternalCnt)
CurrentSheet.Range("A" & LoopCount).Value = AddressArry(0).Alias
CurrentSheet.Range("B" & LoopCount).Value = .Subject
CurrentSheet.Range("C" & LoopCount).Value = .Start
CurrentSheet.Range("D" & LoopCount).Value = .Start
CurrentSheet.Range("E" & LoopCount).Value = .End
CurrentSheet.Range("G" & LoopCount).Value = .EntryID
CurrentSheet.Range("H" & LoopCount).Value = "-"
TextBuff = ""
For i = 1 To UBound(AddressArry) - 1
If AddressArry(i).Name = "" Then
Exit For
End If
If AddressArry(i).External = False Then
If TextBuff = "" Then
TextBuff = AddressArry(i).Alias
Else
TextBuff = TextBuff & ";" & AddressArry(i).Alias
End If
End If
Next i
If ExternalCnt > 0 Then
If TextBuff = "" Then
TextBuff = "外部 " & ExternalCnt & "名"
Else
TextBuff = TextBuff & ";外部 " & ExternalCnt & "名"
End If
End If
CurrentSheet.Range("F" & LoopCount).Value = TextBuff
LoopCount = LoopCount + 1
Else
If .Start < SelectStartDate Then
Exit For
End If
End If
End With
End If
Next OlItem
'Null out the variables.
Set OlItem = Nothing
Set OlItems = Nothing
Set OlFolder = Nothing
Set OlNS = Nothing
Set OlApp = Nothing
'日付順にソート
If LoopCount > 0 Then
With CurrentSheet
Dim EndCol As Long
EndCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A1", Cells(1, EndCol).End(xlDown)).Sort _
Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes
End With
End If
'更新抑制解除
Application.ScreenUpdating = True
MsgBox "予定表の取り込みが完了しました", vbInformation
End Sub
Sub SmtpAddressGet(Recips As Object, Cnt As Long, Address() As AddressType, ExternalCnt As Long)
Dim Recip As Object
Dim ExcUser As Object
Dim ExcDL As Object
Dim PropAccess As Object
Dim EmailAddress As String
Dim ArrayIndex As Long
Dim DomainName As String
Dim MyDomain As Variant
'アドレス取得用
Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ExternalCnt = 0
ReDim Address(Cnt - 1)
ArrayIndex = 0
For Each Recip In Recips
If Recip.Type = olTo Then
Select Case Recip.AddressEntry.AddressEntryUserType
Case olSmtpAddressEntry
Set PropAccess = Recip.PropertyAccessor
EmailAddress = PropAccess.GetProperty(PR_SMTP_ADDRESS)
Case olExchangeUserAddressEntry, olExchangeRemoteUserAddressEntry
Set ExcUser = Recip.AddressEntry.GetExchangeUser
EmailAddress = ExcUser.PrimarySmtpAddress
If EmailAddress = "" Then
Set PropAccess = Recip.PropertyAccessor
EmailAddress = PropAccess.GetProperty(PR_SMTP_ADDRESS)
End If
Case olExchangeDistributionListAddressEntry
Set ExcDL = Recip.AddressEntry.GetExchangeDistributionList
EmailAddress = ExcDL.PrimarySmtpAddress
If EmailAddress = "" Then
Set PropAccess = Recip.PropertyAccessor
EmailAddress = PropAccess.GetProperty(PR_SMTP_ADDRESS)
End If
End Select
If ArrayIndex = 0 Then
Address(ArrayIndex).RecipType = "Owner"
Else
Address(ArrayIndex).RecipType = "To"
End If
Address(ArrayIndex).Name = Recip.Name
Address(ArrayIndex).SMTPAddress = EmailAddress
Address(ArrayIndex).Alias = Left(EmailAddress, InStr(EmailAddress, "@") - 1)
DomainName = Right(EmailAddress, Len(EmailAddress) - InStr(EmailAddress, "@"))
Address(ArrayIndex).External = True
For Each MyDomain In MyDomainList
If UCase(DomainName) = UCase(MyDomain) Then
Address(ArrayIndex).External = False
End If
Next
If Address(ArrayIndex).External = True Then
ExternalCnt = ExternalCnt + 1
End If
ArrayIndex = ArrayIndex + 1
End If
Next Recip
Set Recip = Nothing
Set ExcUser = Nothing
Set ExcDL = Nothing
Set PropAccess = Nothing
End Sub