メールの月次集計用

-
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のサブフォルダとファイル一覧を出力する

-
 タイトルのまんまです。 以前、EXCELで似たようなこと をしていたのでGASではどうするのかなぁと思ってやってみました。まぁほとんど丸パクリです。とりあえず、また使うかもしれないので自分用にメモです。しかしGASでGoogleDriveのファイル一覧嘗め回そうとすると3分かかってしまう。数が多いと6分制限に引っかかるのでこれでは使えない。せいぜい100ファイルとか数が少ないところで使う分にはいいけどダイナミックな場合は何回かに分割してやらないと少し厳しいかもしれない。 ◆GAS //設定値取得 const SHEET_URL = SpreadsheetApp.getActiveSpreadsheet().getUrl(); const ss = SpreadsheetApp.openByUrl(SHEET_URL); const SETTING_SHEET = ss.getSheetByName('設定') const TARGET_FOLDER_ID = SETTING_SHEET.getRange('B2').getValue(); const SAVE_FOLDER_ID = SETTING_SHEET.getRange('B3').getValue(); const SAVE_FILE_NAME = SETTING_SHEET.getRange('B4').getValue(); const SAVE_SHEET_NAME = SETTING_SHEET.getRange('B5').getValue(); function writeSheet(values, labels, sheetUrl, sheetname, width) { /* スプレッドシートに書き出し */ try { if (values.length > 0) { // シートを追加する let spreadSheet = SpreadsheetApp.openByUrl(sheetUrl); let sheet = set_sheet(sheetUrl,sheetname); // 1行目だけヘッダ追加 let he...
続きを読む

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

-
イメージ
危うく3日坊主になりそうでした。とりあえず今日は 「IS-LM分析」 です。 テキストでは 簡便4象限法 とかいうのの説明が多いです。なのでさっぱり わけわからん状態ですが、それなりに頑張ってみます。 1: IS曲線 の導出 財市場の均衡を表す。Iは投資を表し、Sは貯蓄を表す。 ・IS曲線導出の材料 I→利子率の関数、S→所得の関数で「I=S」で財市場を表す。 ・ 投資関数 利子率の減少関数、I (投資関数)=I(r)　※rは利子率 ・政府活動の導入 裁量的な拡張的な財政政策はIS曲線をシフトさせる。 IS曲線の右シフト=政府支出の増大や減税等の有効需要を増加させる要因による 2: LM曲線 の導出 利子率の低下が国民所得の増大につながる因果関係を明らかにする目的 ・LM曲線導出の材料 貨幣需要(MD)=L、L=取引的動機+予備的動機(L1)+投機的動機(L2) MD=L1+L2 貨幣供給(Ms)=名目貨幣供給/物価(P) ・LM曲線のシフト 金融緩和策・物価下落：実質貨幣供給(MS)が増大→右(下)へシフト 金融引締策・物価上昇：実質貨幣供給(MS)が減少→左(上)へシフト 独立投資拡大→IS曲線が右にシフト 利子率がr1→r2に下落する。 IS曲線、LM曲線の均衡点がE→Fに移動する。 国民所得がY1→Yfとなって増大する。 3:特殊なLM曲線 ・ 流動性の罠 のLM曲線 金融政策は無効→LM曲線をシフトさせても均衡点Eは変わらない IS曲線を右にシフトさせる拡張的な財政政策を実施すると均衡点が E→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　 ・ 投資の利子率に対する弾力性ゼロ 金融政策は無効→LM曲線を右にシフトさせても国民所得が増えない。 流動性の罠と同じくIS曲線を右にシフトさせる拡張的な財政政策を実施すると 均衡点がE→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　　　　 4: クラウディング・アウト 政府が市場に介入して公共投資を行うと民間の投資が締出しを受ける ・古典派による財政政策の無効論 政府支出を拡大すると利子率が上昇してしまい。投資が減少する。 政府の支出がクラウディングアウトを引き起こして支...
続きを読む

IEのセキュリティ設定をいじくるバッチ

-
まぁかなり頻出ですがIEでアプリ用に設定しないといけなくて クリックOnlyで処理したかったので色々と調べてみて作ってみた。 ローカルイントラネットの設定いじくるのとActiveX関連をいじくるのと 互換表示設定をいじくっています。 というよりそういう設定しないと動かないアプリの組み方辞めてください。 頼むから・・・。 挙動が微妙に他と違うのでIEとかEdgeには苦しめられます。 @echo off set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap" reg add %REGROOT% /f /v "AutoDetect" /t REG_DWORD /d "0" reg add %REGROOT% /f /v "IntranetName" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "ProxyBypass" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "UNCAsIntranet" /t REG_DWORD /d "1" rem IEのローカルイントラネット設定(*ドメイン指定) set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range1" set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\対象ドメイン" reg add %REGROOT% /f /v "*" /t REG_DWORD /d "1" rem スクリプトを実行しても安全だとマークされていない activex コントロールの初期化とスクリ...
続きを読む