メールの月次集計用

- 5月 13, 2015

ACCESSのVBAとは違うのですがEXCELのVBAで作りました。経緯はというとGoogleスプレッドシートで集計したメール件数を 1か月分まとめて件数推移を見たいという時に使うやつです。グラフ作るの面倒なので少しプチ楽にしてみました。グダグダコードですが一通りやりたいことはできたかなぁと。エラー処理とかは不十分です。まぁ三流PGでして今後の課題ということで目をつぶって
いただけると・・・

取込想定データのフォーマット
A列にカテゴリ、B列にメール受信件数
シート名は年月日(yyyymmdd)が前提となっています。

*5/14：若干、コード微修正
　自動で閉じるようにした。作業月の前月をprefixに

*5/25：若干、コード修正
　ラベル毎集計機能追加と円グラフ自動生成

フォーム側(ボタン1個作ってね)
--------------------------------------------------

Private Sub cmdStart_Click()
'ref http://www.moug.net/tech/exvba/0150079.html
    Dim FN As String
    Dim EF As String
  
    FN = Module1.fileOpen
    Module1.GetData (FN)
　　Module1.CategoryGetData (FN)
  
    EF = MsgBox("処理が終了しました。")
  
    If EF = vbOK Then
        Application.DisplayAlerts = False
        Application.Quit
        ThisWorkbook.Close SaveChanges:=False
    End If

End Sub

モジュール側
--------------------------------------------------

'refer：
' http://officetanaka.net/excel/vba/tips/tips154.htm
' http://www.officepro.jp/excelvba/sub/index6.html
'
' 　ファイル名取得
'
'
Function fileOpen() As String
  
    Dim Target As String
    Dim ForderPath As String
    Dim FileName As String
    Dim preFixDate As String
  
    preFixDate = Format(DateAdd("m", -1, Now()), "yyyymm")
    ForderPath = "フォルダパス"
    FileName = "ファイル名"
  
    Target = ForderPath & preFixDate & FileName
    If Target = "False" Then Exit Function
    fileOpen = Target
  
End Function

'refer:
' http://www.liveway.net/technic/20100810_090030.html
' http://officetanaka.net/excel/vba/file/file01.htm
' http://kuroeveryday.blogspot.jp/2014/12/Try-Catch-Finally.html
' http://www2.odn.ne.jp/excel/waza/macro.html#SEC10
' http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_010.html
' http://www.relief.jp/itnote/archives/excel-vba-for-next-loop-backwards.php
' http://www.excel-vba.net/excel-function-013.html
' http://atamoco.boy.jp/vba/excel/worksheet/Worksheets.Add.php
' http://www.moug.net/tech/exvba/0020012.html
' http://officetanaka.net/excel/vba/tips/tips150.htm
' http://d.hatena.ne.jp/yuri_donovic/20120826/1345965730
' http://www.moug.net/tech/exvba/0050098.html
' http://enjoyvba.blogspot.jp/2012/09/blog-post_11.html
' http://excel.style-mods.net/tips_vba/tips_vba_2_07.htm
' http://www.happy2-island.com/excelsmile/smile03/capter01313.shtml
'
' 　GoogleSpledSheetダウンロードデータを集計する。
'
Sub GetData(FileName As String)
  
    Dim FSO As New FileSystemObject
    Dim File As File
    Dim buf As String
    Dim wb As Workbook
    Dim ReturnBook As String    '開いたブックの保持用
    Dim targetWs As String      '作業用ワークシート
    Dim Nws As Worksheet        '挿入ワークシート用
    Dim i As Long               'シート名取得用
    Dim j As Long               '日付逆転用(カウンター)
    Dim SheetCnt As Long
    Dim DayRev() As String      '日付逆転用
    Const HEADER = 1            '見出用
    Const DAYROW = "A"          '日付列用(A列)
    Const ROWB = "B"            '曜日列用(2シート目は件数)
    Const CNTROW = "C"          '件数用(C列)
    Const AVGROW = "D"          '平均件数用
    Dim RecMail() As Long       'メール件数
    Dim mCnt As Long            'メール件数取得用カウンタ
    Dim sumCnt As String        '集計の合計用に利用
    Dim Graph As String         'グラフ用
    Dim gwidth As Long
    Dim ghight As Long
    Dim GraphLast As Long       'グラフの最終域
    Const height = 400
    Const width = 600
  
    'ファイル関連チェック
    buf = Dir(FileName)
    If buf = "" Then
        MsgBox FileName & vbCrLf & "は存在しません", vbExclamation
        Exit Sub
    End If
    For Each wb In Workbooks
        If wb.Name = buf Then
            MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
            Exit Sub
        End If
    Next wb
      
   'シートの制御
    Workbooks.Open FileName
    With Worksheets.Add(Before:=Worksheets(1))
        .Name = "集計"
    targetWs = ActiveWorkbook.Name
    SheetCnt = Worksheets.Count
  
   '日付がきちんと昇順になるように設定
   '二重にループを回して降順で取得している値を昇順に再展開
        .Range(DAYROW & HEADER).Value = "日付"
        .Range(ROWB & HEADER).Value = "曜日"
        .Range(CNTROW & HEADER).Value = "メール受信件数"
        .Range(AVGROW & HEADER).Value = "平均件数"
        .Range(AVGROW & HEADER).Font.ColorIndex = 2
        ReDim DayRev(SheetCnt)
        ReDim RecMail(SheetCnt)
        j = 1
        For i = SheetCnt To 1 Step -1
            DayRev(j) = Worksheets(i).Name
            '当該シートの中のメール件数を取得
            mCnt = Worksheets(i).Range(ROWB & HEADER).End(xlDown).Row
            For k = 1 To mCnt
                RecMail(j) = Worksheets(i).Range(ROWB & mCnt).Value
            Next
            j = j + 1
        Next i
        j = 1
        For i = 1 To SheetCnt
                .Range(DAYROW & i + 1).Value = Format(DayRev(j), "##/##/##")
                .Range(CNTROW & i + 1).Value = RecMail(j)
                j = j + 1
        Next
      
        '列幅自動調整
        .Range(DAYROW & ":" & CNTROW).EntireColumn.AutoFit
        GraphLast = j - 1
      
        '集計(合計：最終行はグラフに+1)
        sumCnt = "=SUM(" & CNTROW & HEADER & ":" & CNTROW & GraphLast & ")"
        .Range(CNTROW & GraphLast + 1).Value = sumCnt
      
        '平均値挿入(グラフの横軸設定用データのある行に挿入)
        avgLine = "=" & CNTROW & GraphLast + 1 & "/" & GraphLast
        For i = 2 To SheetCnt
            .Range(ROWB & i).Value = .Range(DAYROW & i).Value
            .Range(ROWB & i).NumberFormatLocal = "aaa"
            .Range(AVGROW & i).Value = avgLine
            .Range(AVGROW & i).Font.ColorIndex = 2   '文字を白にする
        Next

        'グラフ作成
        ActiveSheet.Shapes.AddChart.Select
        ActiveChart.ChartType = xlLineMarkers
        'グラフのデータソース指定(集計欄除外)
        Graph = .Name & "!" & DAYROW & HEADER + 1 & ":" & DAYROW & GraphLast & _
        "," & .Name & "!" & CNTROW & HEADER + 1 & ":" & AVGROW & GraphLast
        ActiveChart.SetSourceData Source:=Range(Graph)
        'グラフの大きさ指定
        ActiveChart.ChartArea.Top = Range(DAYROW & HEADER).Top
        ActiveChart.ChartArea.height = CDbl(height)
        ActiveChart.ChartArea.width = CDbl(width)
        '平均の系列はマーカーなしに
        ActiveChart.SeriesCollection.Item(2).MarkerStyle = xlMarkerStyleNone
        '軸のフォントを8に(やや小さく)
        ActiveChart.Axes(xlCategory).TickLabels.Font.Size = 8
        '系列名
        ActiveChart.SeriesCollection(1).Name = "=" & .Name & "!" & CNTROW & HEADER
        ActiveChart.SeriesCollection(2).Name = "=" & .Name & "!" & AVGROW & HEADER
      
    End With
    'ファイルを閉じる
    ActiveWorkbook.Save
    ActiveWorkbook.Close False

End Sub

Sub CategoryGetData(FileName As String)
'refer:http://excel-ubara.com/excel3/EXCEL017.html
'      http://www.officepro.jp/excelvba/chart_edit/index6.html
'
'
' 　ラベル毎の件数を集計する
'
    Dim FSO As New FileSystemObject
    Dim File As File
    Dim buf As String
    Dim wb As Workbook
    Dim ReturnBook As String    '開いたブックの保持用
    Dim targetWs As String      '作業用ワークシート
    Dim Nws As Worksheet        '挿入ワークシート用
   
    Dim SheetCnt As Long
    Const HEADER = 1            '見出用
    Const CATNAME = "A"         'ラベル名
    Const CNTROW = "B"
    Const STARTCNTROW = 2       '開始行
    Dim LabelName() As String   'ラベル名称
   
    Dim lCnt As Long            'ラベル件数取得用カウンタ
    Dim MailCounter() As Long   'メール件数
   
    Dim DailyCnt As Long        '日毎の件数
    Const MSHEET = 2            'シートから差し引く数
    Dim Target As String        'ラベル名取得対象シート
    Dim CompCnt() As Long       '行数比較用
    Dim ColumnIndex As Long     'ラベル毎件数横展開用
    ColumnIndex = 3             'C列から横展開用
   
    Dim Graph As String         'グラフ用
    Const height = 600          'グラフ用
    Const width = 800           'グラフ用

   
    Application.Visible = False
    'ファイル関連チェック
    buf = Dir(FileName)
    If buf = "" Then
        MsgBox FileName & vbCrLf & "は存在しません", vbExclamation
        Exit Sub
    End If
   
    For Each wb In Workbooks
        If wb.Name = buf Then
            MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
            Exit Sub
        End If
    Next wb
       
    Workbooks.Open FileName
   
   'カテゴリ集計シート追加
    With Worksheets.Add(Before:=Worksheets(1))
        .Name = "カテゴリ毎集計"
        targetWs = ActiveWorkbook.Name
        SheetCnt = Worksheets.Count
        DailyCnt = SheetCnt - MSHEET
        ReDim CompCnt(SheetCnt)
        .Range(CATNAME & HEADER).Value = "ラベル名"
        .Range(CNTROW & HEADER).Value = "メール受信件数"
       
   '日毎のラベル件数を比較し最大レコード件数のシートからラベル名を取得する
        For i = SheetCnt To 2 Step -1
            CompCnt(i) = Worksheets(i).Range(CNTROW & HEADER).End(xlDown).Row
            If lCnt < CompCnt(i) Then
                lCnt = CompCnt(i)
                Target = Worksheets(i).Name
            End If
        Next i
       
    'ラベル名書出し
        ReDim LabelName(lCnt)
        ReDim MailCounter(lCnt)
       
        For j = 2 To lCnt
                .Range(CATNAME & j).Value = Worksheets(Target).Range(CATNAME & j).Value
        Next j
   
    '日毎合計件数取得
    'EXCELのラベル部分を固定として1シート総当たり、合致すれば足し込む
        For k = SheetCnt To 2 Step -1
            Cells(1, ColumnIndex).Value = Worksheets(k).Name
           
            For l = STARTCNTROW To lCnt
              LabelName(l) = .Range(CATNAME & l).Value
              For m = STARTCNTROW To lCnt
                   
                    If LabelName(l) = Worksheets(k).Range(CATNAME & m).Value Then
                        MailCounter(l) = MailCounter(l) + CLng(Worksheets(k).Range(CNTROW & m).Value)
                        Cells(l, ColumnIndex).Value = CLng(Worksheets(k).Range(CNTROW & m).Value)
                        Exit For
                    End If
              Next m
              .Range(CNTROW & l).Value = MailCounter(l)
            Next l
            ColumnIndex = ColumnIndex + 1
        Next k
       
    '列幅自動調整
        .Range(CATNAME & ":" & CNTROW).EntireColumn.AutoFit
       
    'グラフ作成
        ActiveSheet.Shapes.AddChart.Select
        ActiveChart.ChartType = xlPie
        'グラフのデータソース指定
        Graph = .Name & "!$B$" & STARTCNTROW & ":" & "$B$" & lCnt - 1 & _
        "," & .Name & "!$A$" & STARTCNTROW & ":" & "$A$" & lCnt - 1
        ActiveChart.SetSourceData Source:=Range(Graph)
       'グラフの大きさ指定
        ActiveChart.ChartArea.Top = Range(.Name & "!$A$" & lCnt + 1).Top
        ActiveChart.ChartArea.height = CDbl(height)
        ActiveChart.ChartArea.width = CDbl(width)
        '凡例のフォントサイズ8に
        ActiveChart.Legend.Font.Size = 8
    End With
   
    Application.Visible = True
    'ファイルを閉じる
    ActiveWorkbook.Save
    ActiveWorkbook.Close False
End Sub

このブログを検索

アラフィフおやじログ

メールの月次集計用

コメント

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

証券外務員1種勉強(計算式暗記用メモ)

マクロ経済学(IS-LM分析)