LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@office-itou(Jun Itou)

VBScriptによるExcelのグラフ作成

Last updated at Posted at 2022-12-08

VBScriptによるExcelのグラフ作成

目的

VBScriptでExcelを制御しデーターの取り込みからグラフの作成・出力までを行う。

結果

2～5分程度でグラフ及びExcelファイルを自動作成できた。
（成果物は参照先のとおり）

環境

  • Microsoft Windows 10 Pro 22H2
  • Microsoft Excel for Microsoft 365 Ver.2211 64bit
  • Core i7-6700のPC上のVMware Workstation 16 Pro (Ver.16.2.4)

作成されたグラフの例

スクリーンショット
pic1.感染者数.png
pic2.感染者数の7日間平均.png
pic3.感染者数の10万人あたり7日間平均.png
pic4.感染者数（東京都）.png
pic5.感染者数（日本国内）.png）
pic6.死者重症者数.png
pic7.感染者数の10万人あたり7日間平均（抜粋）.png

フォルダー構成

フォルダー構成
.
|   covid-19.xlsx （新規作成される成果物）
|   GetCovid19Data.cmd （VBS起動及びダウンロード処理）
|   MakeCovid19Graph.vbs （Excelファイル作成処理）
|
+---conv （ワークファイル）
|       感染者数.0.txt
|       感染者数.1.txt
|       感染者数.2.txt
|       感染者数.3.txt
|       感染者数.4.txt
|       日本国内.txt
|       順位付け.txt
|
+---data （厚労省のデーターをダウンロードしたもの）
|       cluster_events_weekly.csv
|       confirmed_cases_cumulative_daily.csv
|       confirmed_cases_detail_cumulative_weekly.csv
|       deaths_cumulative_daily.csv
|       deaths_detail_cumulative_weekly.csv
|       newly_confirmed_cases_daily.csv
|       newly_confirmed_cases_detail_weekly.csv
|       newly_confirmed_cases_difference.csv
|       newly_confirmed_cases_per_100_thousand_population_daily.csv
|       pcr_case_daily.csv
|       pcr_tested_daily.csv
|       requiring_inpatient_care_etc_daily.csv
|       severe_cases_daily.csv
|       severe_cases_detail_weekly.csv
|       人口(人口推計2019).csv
|       人口(国勢調査2020).csv
|
\---grph （Excelファイルのグラフを出力したもの）
        pic1.感染者数.png
        pic2.感染者数の7日間平均.png
        pic3.感染者数の10万人あたり7日間平均.png
        pic4.感染者数（東京都）.png
        pic5.感染者数（日本国内）.png
        pic6.死者重症者数（日本国内）.png
        pic7.感染者数の10万人あたり7日間平均（抜粋）.png

起動用バッチ:GetCovid19Data.cmd

  • フォルダー作成
  • web上のデーターファイルをダウンロード
  • VBScriptの起動

グラフ作成VBScript:MakeCovid19Graph.vbs

  • CSVファイルをExcelに取り込みやすいように加工しTEXTファイルに出力
  • ExcelにTEXTファイルを読み込み表示形式を編集
  • Excelに取り込んだデーターを基にグラフを作成
  • Excel上のグラフをpngファイルに出力

VBScriptのメモ

CSciptで起動するためのおまじない

CSciptで起動するためのおまじない
    Dim objShell
    Dim Arguments

    If InStr(LCase(WScript.FullName), "cscript.exe") = 0 Then
        For I = 0 To WScript.Arguments.Count - 1
            Arguments = Arguments & " """ & WScript.Arguments.Item(I) & """"
        Next
        Set objShell = CreateObject("WScript.Shell")
        objShell.Run "CScript """ & WScript.ScriptFullName & """ " & Arguments
        Set objShell = Nothing
        WScript.Quit
    End If

ファイル読み込みの例(UTF-8 CSV形式)

ファイル読み込みの例(UTF-8 CSV形式)
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile InpDir & "\" & InpFileName
        InpLine = .ReadText(-2)
        InpCount = 0
        Do Until .EOS
            InpLine = .ReadText(-2)
            InpArray = Split(InpLine, ",")
            省略
        Loop
        OutCount = InpCount
        .Close
    End With

ファイル書き込みの例(UTF-8 TAB形式)

ファイル書き込みの例(UTF-8 TAB形式)
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        For I = 0 To 47
            OutLine = RankData(0, I) & _
             Chr(9) & RankData(1, I) & _
             Chr(9) & RankData(2, I) & _
             Chr(9) & RankData(3, I) & _
             Chr(9) & RankData(4, I)
            .WriteText OutLine, 1
        Next
        .SaveToFile OutDir & "\" & OutFileName, 2
        .Close
    End With

VBScriptでsortの例

VBScriptでsortの例
    With CreateObject("ADODB.Recordset")
        .Fields.Append "CD", 200, 128
        .Fields.Append "NAME", 200, 128
        .Fields.Append "VALUE", 5
        .Open
        For I = 0 To 46
            .AddNew
            .Fields("CD").Value = I + 1                                         Rem 都道府県コード
            .Fields("NAME").Value = OutValue(I + 2, 0, 4)                       Rem 都道府県名
            .Fields("VALUE").Value = OutValue(I + 2, InpCount + 0, 4)           Rem 各地の直近1週間の人口10万人あたりの感染者数
        Next
        .Sort = "VALUE DESC,CD"
        .MoveFirst
        Erase RankData
        ReDim RankData(4, 47)
        RankData(0, 0) = "順位"
        RankData(1, 0) = "都道府県CD"
        RankData(2, 0) = "都道府県名"
        RankData(3, 0) = "感染者数"
        RankData(4, 0) = "コピペ用"
        For I = 1 To 47
            RankData(0, I) = I
            RankData(1, I) = .Fields("CD").Value
            RankData(2, I) = .Fields("NAME").Value
            RankData(3, I) = FormatNumber(Round(.Fields("VALUE").Value, 2), 2, -1, 0, 0)
            RankData(4, I) = RankData(2, I) & ":" & RankData(3, I)
            .MoveNext
        Next
        .Close
    End With

TAB形式のTEXTファイルをExcelのWorkSheetに変換

Call MakeExcelFile
    Call MakeExcelFile("感染者数", "感染者数.0.txt")
    Call MakeExcelFile("7日間平均", "感染者数.1.txt")
    Call MakeExcelFile("10万人", "感染者数.3.txt")
    Call MakeExcelFile("日本国内", "日本国内.txt")
    Call MakeExcelFile("順位付け", "順位付け.txt")
MakeExcelFile
Sub MakeExcelFile(WorkSheetName, InpFileName)
    WScript.Echo "抽出：" & InpFileName
    objExcel.Workbooks.OpenText OutDir & "\" & InpFileName, 65001, , , , , True
    Set objSrcWorkbook = objExcel.Workbooks.Item(objExcel.Workbooks.Count)
    objSrcWorkbook.Worksheets(1).Name = WorkSheetName
    With objExcel
        objSrcWorkbook.Worksheets(1).Select
        .ActiveWindow.FreezePanes = False
        .Range("B2").Select
        .ActiveWindow.FreezePanes = True
        .Application.ScreenUpdating = False
        Select Case WorkSheetName
            Case "順位付け"
            Case Else
                For I = 2 To .Cells(1, 1).End(-4161).Column
                    With .Range(.Cells(2, I), .Cells(.Rows.Count, I).End(-4162))
                        .FormatConditions.AddTop10
                        With .FormatConditions(1)
                            .TopBottom = 1
                            .Rank = 1
                            .Percent = False
                            .Font.Color = -16776961
                            .Font.TintAndShade = 0
                            .StopIfTrue = False
                        End With
                    End With
                Next
        End Select
        Select Case WorkSheetName
            Case "感染者数"
                .Range("A1:AW1").HorizontalAlignment = -4108
                .Range("A1:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).ShrinkToFit = True
                .Range("B2:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
            Case "7日間平均"
                .Range("A1:AW1").HorizontalAlignment = -4108
                .Range("A1:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).ShrinkToFit = True
                .Range("B2:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
            Case "10万人"
                .Range("A1:AW1").HorizontalAlignment = -4108
                .Range("A1:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).ShrinkToFit = True
                .Range("B2:AW" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.0"
            Case "日本国内"
                .Range("A1:P1").HorizontalAlignment = -4108
                .Range("A1:P" & (.Cells(.Rows.Count, 1).End(-4162).Row)).ShrinkToFit = True
                .Range("B2:B" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("C2:C" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
                .Range("D2:D" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
                .Range("E2:E" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
                .Range("F2:F" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("G2:G" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("H2:H" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
                .Range("I2:I" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("J2:J" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("K2:K" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
                .Range("L2:L" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("M2:M" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("N2:N" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("O2:O" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("P2:P" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0"
                .Range("G116").FormatConditions.Delete
            Case "順位付け"
                .Range("A1:E1").HorizontalAlignment = -4108
                .Range("A1:E" & (.Cells(.Rows.Count, 1).End(-4162).Row)).ShrinkToFit = True
                .Range("D2:D" & (.Cells(.Rows.Count, 1).End(-4162).Row)).NumberFormatLocal = "0.00"
        End Select
        If .Range("A1").Text = "日付" Then
            With .Range("A2:A" & (.Cells(.Rows.Count, 1).End(-4162).Row))
                .NumberFormatLocal = "yyyy/mm/dd(aaa)"
                .HorizontalAlignment = -4108
            End With
            .Columns("A").AutoFit
        End If
        .Cells.EntireRow.AutoFit
        If .Range("A1").Text = "日付" Then
            .Range("B" & (.Cells(.Rows.Count, 2).End(-4162).Row)).Select
        Else
            .Range("B2").Select
        End If
        .Application.ScreenUpdating = True
    End With
    objSrcWorkbook.Worksheets(1).Move , objDstWorkbook.Worksheets(objDstWorkbook.Sheets.Count)
    Set objSrcWorkbook = Nothing
End Sub

ExcelのWorkSheetをグラフに変換

Class
Rem ---------------------------------------------------------------------------
Class ClassCollection
    Public Name                                             '
    Public XValues                                          '
    Public Values                                           '
    Public AxisGroup                                        '
End Class

Class ClassGraph
    Private I

    Public WorksheetGrph                                    'Worksheet:グラフ
    Public WorksheetData                                    'Worksheet:データー
    Public Left                                             '描画範囲:左からの位置
    Public Top                                              '   〃   :上からの位置
    Public Width                                            '   〃   :描画する幅
    Public Height                                           '   〃   :描画する高さ
    Public ChartTitleText                                   'グラフタイトル
    Public Collection(3)                                    'グラフ情報

    Private Sub Class_Initialize()
        For I = LBound(Collection) To UBound(Collection)
            Set Collection(I) = New ClassCollection
        Next
    End Sub

    Private Sub Class_Terminate()
        For I = LBound(Collection) To UBound(Collection)
            Set Collection(I) = Nothing
        Next
    End Sub
End Class

Dim clsGraph
Call MakeGraph（その１）
Rem ---  3: 10万人あたりの感染者数 ----------------------------------------
Set clsGraph = New ClassGraph
With clsGraph
    Set .WorksheetGrph = objDstWorkbook.Worksheets("グラフ")
    Set .WorksheetData = objDstWorkbook.Worksheets("10万人")
    .Left = 0
    .Top = 600
    .Width = 912
    .Height = 585
    .ChartTitleText = "感染者数の10万人あたり7日間平均"
    Call MakeGraph(clsGraph, "描画：3: " & .ChartTitleText, False)
End With
Set clsGraph = Nothing
Call MakeGraph（その２）
Rem ---  4: 感染者数（東京都） --------------------------------------------
Set clsGraph = New ClassGraph
With clsGraph
    Set .WorksheetGrph = objDstWorkbook.Worksheets("グラフ")
    Set .WorksheetData = objDstWorkbook.Worksheets("感染者数")
    .Left = 960
    .Top = 600
    .Width = 912
    .Height = 585
    .ChartTitleText = "感染者数（東京都）"
    With .Collection(0)
        .Name = "=""感染者数"""
        .XValues = "=感染者数!$A$2:$A$"
        .Values = "=感染者数!$O$2:$O$"
        .AxisGroup = 1
    End With
    With .Collection(1)
        .Name = "=""7日間平均"""
        .XValues = "=感染者数!$A$2:$A$"
        .Values = "=7日間平均!$O$2:$O$"
        .AxisGroup = 1
    End With
    With .Collection(2)
        .Name = "=""10万人"""
        .XValues = "=感染者数!$A$2:$A$"
        .Values = "=10万人!$O$2:$O$"
        .AxisGroup = 2
    End With
    Call MakeGraph(clsGraph, "描画：4: " & .ChartTitleText, False)
End With
Set clsGraph = Nothing
MakeGraph
Sub MakeGraph(clsGraph, MessageText, LatestFlag)
    Dim I                               'For Next用
    Dim objWorksheetGrph                'Worksheet:グラフ
    Dim objWorksheetData                'Worksheet:データー
    Dim objChart                        'Chart
    Dim RowsEnd                         'データーの存在する最終行
    Dim objRangeMax                     '最大値の検索範囲
    Dim MaxValue                        '最大値の値
    Dim MaxColumn                       '最大値の列
    Dim MaxRow                          '最大値の行
    Dim LatestValue                     '最新の値
    Dim LatestColumn                    '最新の列
    Dim LatestRow                       '最新の行
    Dim RecordsetCount                  'データーラベル件数
    Dim Point(1, 47, 3)                 'データーラベル情報
    Dim objRecordset(1)                 'ソート用オブジェクト
    Dim objWorksheetRank                'Worksheet:順位付け
    Dim objRangeRank                    '順位付け上位３位までの範囲
    Dim aryStrings                      '

    WScript.Echo MessageText
    Rem -----------------------------------------------------------------------
    Set objWorksheetGrph = clsGraph.WorksheetGrph
    Set objWorksheetData = clsGraph.WorksheetData
    With clsGraph
        Set objChart = .WorksheetGrph.ChartObjects.Add(.Left, .Top, .Width, .Height)
    End With
    Rem -----------------------------------------------------------------------
    objExcel.Application.ScreenUpdating = True
    objWorksheetGrph.Range(objChart.TopLeftCell.Address(False, False)).Select
    objExcel.Application.ScreenUpdating = False
    Rem --- 順位付け関連 ------------------------------------------------------
    Set objWorksheetRank = objDstWorkbook.Worksheets("順位付け")
    Set objRangeRank = objWorksheetRank.Range("B2:B6")      '上位5件
    Rem --- データーソース関連 ------------------------------------------------
    With objWorksheetData
        LatestRow = .Cells(.Rows.Count, 2).End(-4162).Row   '合計列
        RowsEnd = .Cells(.Rows.Count, 1).End(-4162).Row     '日付列
    End With
    Rem --- グラフの描画 ------------------------------------------------------
    With objChart.Chart
        .ChartArea.Font.Name = "Meiryo UI"
        .ChartArea.Font.Size = 8
        Rem --- タイトル ------------------------------------------------------
        .HasTitle = True
        .ChartTitle.Text = clsGraph.ChartTitleText
        .ChartTitle.Font.Size = 8
        Rem --- グラフの種類 --------------------------------------------------
        .ChartType = 4
        Rem --- 凡例 ----------------------------------------------------------
        .Legend.Position = -4107
        .Legend.Font.Size = 6
        Rem --- データーの選択 ------------------------------------------------
        If clsGraph.Collection(LBound(clsGraph.Collection)).Name = "" Then
            .SetSourceData objWorksheetData.Range("A1:AW" & RowsEnd)
        Else
            For I = LBound(clsGraph.Collection) To UBound(clsGraph.Collection)
                If clsGraph.Collection(I).Name <> "" Then
                    .SeriesCollection.NewSeries
                    With .FullSeriesCollection(I + 1)
                        .Name = clsGraph.Collection(I).Name
                        .XValues = clsGraph.Collection(I).XValues & RowsEnd
                        .Values = clsGraph.Collection(I).Values & RowsEnd
                        .AxisGroup = clsGraph.Collection(I).AxisGroup
                    End With
                End If
            Next
        End If
        Rem --- 表示範囲の設定 ------------------------------------------------
        If LatestFlag = True Then
            .Axes(1, 1).MinimumScale = CDbl(CDate("2022/01/01"))
            .Axes(1, 1).MaximumScale = CDbl(CDate("2023/06/30"))
            .Axes(1, 1).MajorUnit = 7                       '7日単位
            .Axes(1, 1).MajorUnitScale = 0                  '日単位
        Else
            .Axes(1, 1).MinimumScale = CDbl(CDate("2020/01/01"))
            .Axes(1, 1).MaximumScale = CDbl(CDate("2024/12/31"))
            .Axes(1, 1).MajorUnit = 1                       '1月単位
            .Axes(1, 1).MajorUnitScale = 1                  '月単位
        End If
        Rem --- 縦横軸の設定 --------------------------------------------------
        .Axes(1, 1).TickLabels.Font.Size = 6                '横（項目）軸
        .Axes(2, 1).TickLabels.Font.Size = 6                '縦（値）軸（プライマリー）
        If .Axes.Count > 2 Then
            .Axes(2, 2).TickLabels.Font.Size = 6            '縦（値）軸（セカンダリー）
        End If
        objExcel.Application.ScreenUpdating = True
        Rem -------------------------------------------------------------------
        objExcel.Application.ScreenUpdating = False
        Rem --- グラフの表示制御 ----------------------------------------------
        If clsGraph.Collection(LBound(clsGraph.Collection)).Name = "" Then
            For I = 1 To .FullSeriesCollection.Count
                Select Case I
                    Case 1
                        .FullSeriesCollection(I).IsFiltered = True
                    Case 2, 12, 13, 14, 15, 24, 28, 37, 41, 47, 48
                        .FullSeriesCollection(I).IsFiltered = False
                    Case Else
                        .FullSeriesCollection(I).IsFiltered = True
                End Select
                If Not objRangeRank.Find((I - 1), , -4123, 1) Is Nothing Then
                    .FullSeriesCollection(I).IsFiltered = False
                End If
            Next
        End If
        Rem --- データーラベルの描画 ------------------------------------------
        For I = 1 To .FullSeriesCollection.Count
            If .FullSeriesCollection(I).IsFiltered = False Then
                Rem --- 選択されたグラフの最大値の位置を取得 ------------------
                If clsGraph.Collection(LBound(clsGraph.Collection)).Name = "" Then
                    With objWorksheetData
                        Set objRangeMax = .Range(.Cells(2, I + 1), .Cells(LatestRow, I + 1))
                        MaxValue = objExcel.Max(objRangeMax)
                        With objRangeMax.Find(MaxValue, , -4123, 1)
                            MaxColumn = .Column - 1
                            MaxRow = .Row - 1
                        End With
                    End With
                Else
                Rem --- 選択されたグラフの最大値の位置を取得 ------------------
                    aryStrings = Split(Mid(clsGraph.Collection(I - 1).Values, 2), "!")
                    If aryStrings(0) = "日本国内" And Left(aryStrings(1), 2) = "$G" Then
                        Set objRangeMax = objDstWorkbook.Worksheets(aryStrings(0)).Range("$G$117:$G$" & LatestRow)
                    Else
                        Set objRangeMax = objDstWorkbook.Worksheets(aryStrings(0)).Range(aryStrings(1) & LatestRow)
                    End If
                    MaxValue = objExcel.Max(objRangeMax)
                    With objRangeMax.Find(MaxValue, , -4123, 1)
                        MaxColumn = .Column - 1
                        MaxRow = .Row - 1
                    End With
                End If
            End If
            Rem --- データーラベルの描画 (最大値) -----------------------------
            If .FullSeriesCollection(I).IsFiltered = False Then
                With .FullSeriesCollection(I).Points(MaxRow)
                    PointTop = .Top
                    .ApplyDataLabels
                    With .DataLabel
                        .ShowSeriesName = -1
                        .ShowCategoryName = -1
                        .ShowLegendKey = -0
                        .Separator = " "
                        .Font.Name = "Meiryo UI"
                        .Font.Size = 6
                        .Position = -4131
                        With .Format.TextFrame2
                            .AutoSize = 1
                            .WordWrap = 0
                            .MarginLeft = 0
                            .MarginRight = 0
                            .MarginTop = 0
                            .MarginBottom = 0
                        End With
                        With .Format.Fill
                            .Visible = -1
                            .ForeColor.RGB = RGB(255, 255, 0)
                        End With
                        .Left = .Left - 20
                        .Height = .Font.Size + 1.5
                        .Top = PointTop - .Height / 2
                    End With
                End With
                Rem --- データーラベルの描画 (最新値) -------------------------
                With .FullSeriesCollection(I).Points(LatestRow - 1)
                    PointTop = .Top
                    .ApplyDataLabels
                    With .DataLabel
                        .ShowSeriesName = -1
Rem                     .ShowCategoryName = -1
                        .ShowLegendKey = -0
                        .Separator = " "
                        .Font.Name = "Meiryo UI"
                        .Font.Size = 8
                        .Position = -4152
                        With .Format.TextFrame2
                            .AutoSize = 1
                            .WordWrap = 0
                            .MarginLeft = 0
                            .MarginRight = 0
                            .MarginTop = 0
                            .MarginBottom = 0
                        End With
                        With .Format.Fill
                            .Visible = -1
                            .ForeColor.RGB = RGB(255, 255, 0)
                        End With
                        .Left = .Left + 20
                        .Height = .Font.Size + 1.5
                        .Top = PointTop - .Height / 2
                    End With
                End With
                Rem --- データーラベルの取得 (最大値) -------------------------
                Point(0, RecordsetCount, 0) = I
                Point(0, RecordsetCount, 1) = MaxRow
                Rem --- データーラベルの取得 (最新値) -------------------------
                Point(1, RecordsetCount, 0) = I
                Point(1, RecordsetCount, 1) = LatestRow - 1
                RecordsetCount = RecordsetCount + 1
            End If
        Next
        Rem --- データーラベルの取得 ------------------------------------------
        objExcel.Application.ScreenUpdating = True
        For I = 0 To 1
            For J = 0 To RecordsetCount - 1
                With .FullSeriesCollection(Point(I, J, 0)).Points(Point(I, J, 1)).DataLabel
                    Point(I, J, 2) = .Top
                    Point(I, J, 3) = .Height
                End With
            Next
        Next
        objExcel.Application.ScreenUpdating = False
        Rem --- データーラベルの調整 ------------------------------------------
        For I = 0 To 1
            Set objRecordset(I) = CreateObject("ADODB.Recordset")
            With objRecordset(I)
                Rem --- データーラベルの調整 (初期化) -------------------------
                .Fields.Append "CD", 5
                .Fields.Append "POINT", 5
                .Fields.Append "TOP", 5
                .Fields.Append "HEIGHT", 5
                .Open
                Rem --- データーラベルの調整 (取得) ---------------------------
                For J = 0 To RecordsetCount - 1
                    .AddNew
                    .Fields("CD").Value = Point(I, J, 0)
                    .Fields("POINT").Value = Point(I, J, 1)
                    .Fields("TOP").Value = Point(I, J, 2)
                    .Fields("HEIGHT").Value = Point(I, J, 3)
                    .Sort = "TOP DESC,CD"
                Next
                .MoveFirst
                Rem --- データーラベルの調整 (設定) ---------------------------
                PosiTop = -1
                For J = 1 To RecordsetCount
                    If PosiTop < 0 Then
                        PosiTop = .Fields("TOP").Value
                    ElseIf (PosiTop - .Fields("HEIGHT").Value) > .Fields("TOP").Value Then
                        PosiTop = .Fields("TOP").Value
                    Else
                        PosiTop = PosiTop - .Fields("HEIGHT").Value
                    End If
                    objChart.Chart.FullSeriesCollection(.Fields("CD").Value).Points(.Fields("POINT").Value).DataLabel.Top = PosiTop
                    .MoveNext
                Next
                .Close
            End With
            Set objRecordset(I) = Nothing
        Next
    End With
    With objWorksheetGrph
        .Shapes(.Shapes.Count).AlternativeText = clsGraph.ChartTitleText
    End With
    objExcel.Application.ScreenUpdating = True
End Sub
  • objExcel.Application.ScreenUpdating = True / False が点在しているのは処理時間を短縮したいもののデーターラベルの描画される位置が表示状態でないと確定しないため
  • .FullSeriesCollection(I).IsFiltered = True で予め表示不要な項目のフィルター処理をした方がグラフの処理時間が短くなる
Call FormatDateTime & FormatSecond2DateTime
Dim StartTime
Dim EndTime

StartTime = CDate(Now)
WScript.Echo FormatDateTime(StartTime)
省略
EndTime = CDate(Now)
WScript.Echo "経過：" & FormatSecond2DateTime(DateDiff("s", StartTime, EndTime))
WScript.Echo FormatDateTime(EndTime)

日付時刻の書式設定

FormatDateTime
Function FormatDateTime(DateTimeValue)
    Dim strYear
    Dim strMonth
    Dim strDay
    Dim strHour
    Dim strMinute
    Dim strSecond
    Dim strWeekday

    If IsDate(DateTimeValue) = False Then
        FormatDateTime = Null
        Exit Function
    End If

    strYear = Right("0000" & Year(Now), 4)
    strMonth = Right("00" & Month(DateTimeValue), 2)
    strDay = Right("00" & Day(DateTimeValue), 2)
    strHour = Right("00" & Hour(DateTimeValue), 2)
    strMinute = Right("00" & Minute(DateTimeValue), 2)
    strSecond = Right("00" & Second(DateTimeValue), 2)
    strWeekday = WeekdayName(Weekday(DateTimeValue), True)

    FormatDateTime = strYear & "/" & strMonth & "/" & strDay & "(" & strWeekday & ")" & " " & strHour & ":" & strMinute & ":" & strSecond
End Function
FormatSecond2DateTime
Function FormatSecond2DateTime(SecondValue)
    Dim strHour
    Dim strMinute
    Dim strSecond

    If (SecondValue \ 3600) < 100 Then
        strHour = Right("00" & SecondValue \ 3600, 2)
    Else
        strHour = SecondValue \ 3600
    End If
    strMinute = Right("00" & SecondValue \ 60 Mod 60, 2)
    strSecond = Right("00" & SecondValue Mod 60, 2)

    FormatSecond2DateTime = strHour & ":" & strMinute & ":" & strSecond
End Function

参照

office-itou/Files/excel/covid-19

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?