vbscript Excel VBA便利关数

Posted 2021-05-22

' カラーマップに従ってセルを色付け
Sub SampleCells()
    Dim i As Integer
    
    Range("A1").Value = "index"
    Range("B1").Value = "color"
    
    For i = 1 To 50
        With Cells(i + 1, 1)
            .Value = i ' Value
            .Offset(0, 1).Interior.ColorIndex = i ' カラーインデックスを指定
            .Offset(0, 2).Interior.Color = RGB(i * 5, i * 5, i * 5) ' RGBで指定
        End With
    Next i
End Sub

' カラーマップのインデックス番号順に疑似カラーを設定
Sub setColorMap()
    With ThisWorkbook
        .Colors(1) = RGB(0, 0, 255)
        .Colors(2) = RGB(0, 10, 255)
        .Colors(3) = RGB(0, 40, 255)
        .Colors(4) = RGB(0, 60, 255)
        .Colors(5) = RGB(0, 80, 255)
        .Colors(6) = RGB(0, 100, 255)
        .Colors(7) = RGB(0, 125, 255)
        .Colors(8) = RGB(0, 150, 255)
        .Colors(9) = RGB(0, 170, 255)
        .Colors(10) = RGB(0, 190, 255)
        .Colors(11) = RGB(0, 210, 255)
        .Colors(12) = RGB(0, 230, 255)
        .Colors(13) = RGB(0, 255, 255)
        .Colors(14) = RGB(0, 255, 235)
        .Colors(15) = RGB(0, 255, 215)
        .Colors(16) = RGB(0, 255, 195)
        .Colors(17) = RGB(0, 255, 175)
        .Colors(18) = RGB(0, 255, 155)
        .Colors(19) = RGB(0, 255, 135)
        .Colors(20) = RGB(0, 255, 115)
        .Colors(21) = RGB(0, 255, 95)
        .Colors(22) = RGB(0, 255, 75)
        .Colors(23) = RGB(0, 255, 55)
        .Colors(24) = RGB(0, 255, 35)
        .Colors(25) = RGB(0, 255, 0)
        .Colors(26) = RGB(20, 255, 0)
        .Colors(27) = RGB(40, 255, 0)
        .Colors(28) = RGB(60, 255, 0)
        .Colors(29) = RGB(80, 255, 0)
        .Colors(30) = RGB(100, 255, 0)
        .Colors(31) = RGB(120, 255, 0)
        .Colors(32) = RGB(140, 255, 0)
        .Colors(33) = RGB(160, 255, 0)
        .Colors(34) = RGB(180, 255, 0)
        .Colors(35) = RGB(200, 255, 0)
        .Colors(36) = RGB(220, 255, 0)
        .Colors(37) = RGB(240, 255, 0)
        .Colors(38) = RGB(255, 255, 0)
        .Colors(39) = RGB(255, 235, 0)
        .Colors(40) = RGB(255, 215, 0)
        .Colors(41) = RGB(255, 195, 0)
        .Colors(42) = RGB(255, 175, 0)
        .Colors(43) = RGB(255, 150, 0)
        .Colors(44) = RGB(255, 130, 0)
        .Colors(45) = RGB(255, 110, 0)
        .Colors(46) = RGB(255, 75, 0)
        .Colors(47) = RGB(255, 55, 0)
        .Colors(48) = RGB(255, 35, 0)
        .Colors(49) = RGB(255, 15, 0)
        .Colors(50) = RGB(255, 0, 0)
    End With
End Sub

Option Base 0 ' 添え字の最小値は常時０

Sub CellChange()
    Worksheets("Sheet1").range("A2").Value = "Hello1"
    range("A3").Value = "Hello2"
    Cells(4, 1).Value = "Hello3"
    Cells(4, 1).Offset(1, 0).Value = "Hello4"
End Sub

Sub CellsChange()
    range("B2", "C4").Value = "Hello5"
    range("B5:C7").Value = "Hello6"
    range("C:C").Value = "C"
    range("8:8").Value = "col 8"
    ' Cells.Clear
End Sub

Sub WithTest()
    With range("A2")
        .Value = "hello"
        With .Font
            .Bold = True
            .Size = 16
            .name = "Times New Roman"
        End With
        .Interior.Color = vbRed
    End With
End Sub

Sub VariableTest()
    Dim x As Integer
    x = 10
    Debug.Print (x) ' イミディエイトウィンドウに表示
    x = x + 2
    Debug.Print (x)
    
    ' 和: +, 差: -, 積: *, 除算: /
    ' 商: \, 余り: mod, べき乗: ^
    
    Dim y As Double
    Dim s As String
    Dim d As Date
    Dim z As Variant ' autoみたいな
    Dim F As Boolean
    Dim r As range
    
    y = 10.5
    s = "Hello"
    d = "2012/04/12"
    F = True
    Set r = range("A2") ' オブジェクト型はSetをつける
    
    Debug.Print (y / 3)
    Debug.Print (s & "world")
    Debug.Print d + 7 ' 7日後
    r.Value = d + 7
    
    ' 配列
    Dim sales(0 To 2) As Integer
    sales(0) = 200
    sales(1) = 150
    sales(2) = 300
    
    Debug.Print (sales(1))
    
    Dim sales2 As Variant
    sales2 = Array(200, 150, 300)
    
    Debug.Print (sales(2))
    
    ' 可変配列としてのCollection
    Dim cll As Collection
    Set cll = New Collection
    
    cll.Add ("test")
    cll.Add (CDate("2017/2/4 23:13"))
    cll.Add (CLng(3234))
    cll.Add (40.54)
    
    Dim vData As Variant
    For Each vData In cll
        Debug.Print TypeName(vData) & ":" & vData
    Next
    Set cll = Nothing
    
    ' 連想配列としてのCollection
    Dim cll2 As New Collection

   Call cll2.Add("りんご", "赤")
   Call cll2.Add("みかん", "黄")
   Call cll2.Add("ぶどう", "紫")


   Debug.Print "(1)-------------------------"
   ' 値の列挙
   For Each vData In cll2
       Debug.Print TypeName(vData) & ":" & vData
   Next

   Debug.Print "-------------------------"
   ' キーに赤を指定することによりりんごが表示
   Debug.Print cll2.Item("赤")


   Debug.Print "(2)-------------------------"
   ' キーを指定して黄を削除
   Call cll2.Remove("黄")
   ' 値の列挙
   For Each vData In cll2
       Debug.Print TypeName(vData) & ":" & vData
   Next

   Set cll = Nothing
    
    
    
End Sub

' If文
Sub IfTest()

    If range("A2").Value > 80 Then
        range("A3").Value = "OK"
    ElseIf range("A2").Value > 60 Then
        range("A3").Value = "soso..."
    Else
        range("A3").Value = "NG"
    End If
        
End Sub

' Select文
Sub SelectTest()
    Dim signal As String
    signal = range("A2").Value
    
    Dim result As range
    Set result = range("A3")
    
    Select Case signal
        Case "red"
            result.Value = "STOP!"
        Case "green"
            result.Value = "GO!"
        Case "yellow"
            result.Value = "CAUTION!"
        Case Else
            result.Value = "N.A."
    End Select
End Sub

' while
Sub WhileTest()
    Dim i As Integer
    i = 1
    Do While i < 10
        Cells(i + 1, 1).Value = i
        i = i + 1
    Loop
End Sub

' for
Sub ForTest()
    Dim i As Integer
    For i = 1 To 9 Step 2
        Cells(i + 1, 1).Value = i
    Next i
End Sub

' for each
Sub ForEachTest()
    Dim names As Variant
    names = Array("taguchi", "fkoji", "dotinstall")
    
    For Each name In names
        Debug.Print (name)
    Next name
End Sub

' call プロシージャから他のプロシージャを呼ぶ
Sub callTest()
    Dim names As Variant
    names = Array("taguchi", "fkoji", "dotinstall")
    
    For Each name In names
        Call SayHi(name)
    Next name
End Sub

' ByValは値渡し, ByRefは参照渡し
Sub SayHi(ByVal name As String)
    Debug.Print "Hi! " & name
End Sub

' call プロシージャから他のプロシージャを呼ぶ
Sub callTest2()
    Dim names As Variant
    names = Array("taguchi", "fkoji", "dotinstall")
    
    For Each name In names
       Debug.Print SayHi2(name)
    Next name
End Sub

' Subプロシージャは戻り値なし、Functionプロシージャは戻り値あり
Function SayHi2(ByVal name As String)
    SayHi2 = "Hi!, " & name
End Function

' シート操作
Sub SheetTest()

    
    ActiveWorkbook.Sheets("Sheet1").Cells(3, 3).Value = "test1"
    Workbooks("Common.xlsm").Sheets(1).Cells(3, 4).Value = "test2"
    ThisWorkbook.Sheets(1).Cells(3, 5).Value = "test3"
    
    Worksheets("sheet2").Activate
    
    ' xlContinuous: 実線(細)
    ' xlDash: 破線
    ' xlDashDot: 一点鎖線
    ' xlDashDotDot: 二点鎖線
    ' xlDot: 点線
    ' xlDouble: 二重線
    ' xlSlantDashDot: 斜め斜線
    ' xlLineStyleNone: なし
    range(Cells(1, 1), Cells(2, 2)).Borders.LineStyle = xlContinuous
    range(Cells(1, 1), Cells(2, 2)).Borders.Color = vbRed
    range("B4").Borders(xlEdgeLeft).LineStyle = None
    range("B4").Borders(xlEdgeRight).LineStyle = None
    range("B4").Borders(xlEdgeTop).LineStyle = None
    range("B4").Borders(xlEdgeBottom).LineStyle = xlContinuous
    
    range("B7:C10").Select
    
End Sub

' plot main
Sub plot()
    If Application.ActiveChart Is Nothing Then
        MsgBox "Select Graph Object"
        Exit Sub
    End If

    Call setGraphSize(600, 400)
    Call setTitle("Sample Graph")
    Call setGridOn(True)
    Call setLabels("x-lab", "y-lab")
    Call setLimits(Array(-1, 6, 1), Array(-10, 60, 10))
    Call setFonts("Times New Roman", 15)
    Dim legends As Variant
    legends = Array("series 1", "series 2", "series 3")
    Call setLegends(legends)

    Call plotScatterGraph(True)
End Sub

' @title setGraphSize
' @brief This function sets size of ChartObject which is selected.
' @param(width)  width of Chart Area
' @param(height) height of Chart Area
Function setGraphSize(width, height)
    With ActiveChart
        .ChartArea.width = width
        .ChartArea.height = height
        .PlotArea.width = .ChartArea.width * 0.9
        .PlotArea.height = .ChartArea.height * 0.85
        .PlotArea.Top = .ChartArea.height * 0.01
        .PlotArea.Left = .ChartArea.width * 0.08

        ' Chart Area frame
        .ChartArea.Border.LineStyle = 0

        ' Background Color
        .ChartArea.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
        .PlotArea.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
        
        ' frame line
        .PlotArea.Format.Line.Style = msoLineSingle
        .PlotArea.Format.Line.Visible = True
        .PlotArea.Format.Line.Weight = 0.5
        .PlotArea.Format.Line.ForeColor.RGB = RGB(0, 0, 0)

        .Axes(xlCategory).HasMajorGridlines = False
        .Axes(xlValue).HasMajorGridlines = False
        .Axes(xlCategory).MajorTickMark = xlTickMarkNone
        .Axes(xlValue).MajorTickMark = xlTickMarkNone


        ' 横軸 線の太さと色
        .Axes(xlCategory).Format.Line.Weight = 0.5
        .Axes(xlCategory).Format.Line.ForeColor.RGB = RGB(0, 0, 0)

        ' 縦軸 線の太さと色
        .Axes(xlValue).Format.Line.Weight = 0.5
        .Axes(xlValue).Format.Line.ForeColor.RGB = RGB(0, 0, 0)

    End With
End Function

' @title setTitle
' @brief This function sets title of ChartObject which is selected.
' @param(title) title of graph
Function setTitle(ByVal title As String)
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Text = title
        .ChartTitle.Font.Color = RGB(0, 0, 0)
        .ChartTitle.Top = .ChartArea.height * 0.95
        .ChartTitle.Left = .ChartArea.width * 0.45
    End With
End Function

' @title setGridOn
' @brief This functions sets grid on PlotArea
' @brief(withGrid) select grid option
Function setGridOn(ByVal withGrid As Boolean)
    With ActiveChart
        .Axes(xlCategory).HasMajorGridlines = withGrid
        .Axes(xlValue).HasMajorGridlines = withGrid

        ' 目盛り xlTickMark*** : 末尾はInside, Outside, Cross, None
        .Axes(xlCategory).MajorTickMark = xlTickMarkInside ' 横軸
        .Axes(xlValue).MajorTickMark = xlTickMarkInside ' 縦軸

        ' Major Unit setting
        .Axes(xlCategory).MajorGridlines.Border.LineStyle = xlDash
        .Axes(xlCategory).MajorGridlines.Border.Color = RGB(100, 100, 100)

        .Axes(xlValue).MajorGridlines.Border.LineStyle = xlDash
        .Axes(xlValue).MajorGridlines.Border.Color = RGB(100, 100, 100)
    End With
End Function

' @title setLabels
' @brief This function sets labels of X-axis and Y-axis
Function setLabels(ByVal xlabel As String, ByVal ylabel As String)
    With ActiveChart
        
        ' X-Axis
        .Axes(xlCategory).HasTitle = True
        .Axes(xlCategory).AxisTitle.Text = xlabel
        .Axes(xlCategory).AxisTitle.Font.Color = RGB(0, 0, 0)
        .Axes(xlCategory).AxisTitle.Top = .ChartArea.height * 0.9
        .Axes(xlCategory).AxisTitle.Left = .ChartArea.width * 0.5

        ' Y-Axis
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = ylabel
        .Axes(xlValue).AxisTitle.Font.Color = RGB(0, 0, 0)
        .Axes(xlValue).AxisTitle.Top = .ChartArea.height * 0.8 * 0.5
        .Axes(xlValue).AxisTitle.Left = .ChartArea.width * 0.05
    End With
End Function

' @title setLimits
' @brief This function sets limit ranges of X-axis and Y-axis
' @param(xlim)
' @param(ylim)
Function setLimits(ByVal xlim As Variant, ByVal ylim As Variant)

    With ActiveChart
    ' ----- 横軸のスケール -----'
        ' 種類 xlTickLabelPosition*** : 末尾はNextToAxis, High, Low, None
        .Axes(xlCategory).TickLabelPosition = xlTickLabelPositionLow

        .Axes(xlCategory).TickLabels.Offset = 100 ' 軸からの距離 0~1000 [%]
        .Axes(xlCategory).TickLabels.Orientation = 0 ' スケールの向き -90~90 [degree]

        .Axes(xlCategory).MinimumScale = xlim(0) ' 最小値
        .Axes(xlCategory).MaximumScale = xlim(1) ' 最大値
        .Axes(xlCategory).MajorUnit = xlim(2)  ' 刻み

        .Axes(xlCategory).TickLabels.NumberFormat = "0" ' 数値の表示形式  少数点以下の桁数を指定できます。

    ' ----- 縦軸のスケール -----'
        ' 種類 xlTickLabelPosition*** : 末尾はNextToAxis, High, Low, None
        .Axes(xlValue).TickLabelPosition = xlTickLabelPositionLow

        .Axes(xlValue).TickLabels.Offset = 100 ' 軸からの距離 0~1000 [%]
        .Axes(xlValue).TickLabels.Orientation = 0 ' スケールの向き -90~90 [degree]

        .Axes(xlValue).MinimumScale = ylim(0) ' 最小値
        .Axes(xlValue).MaximumScale = ylim(1) ' 最大値
        .Axes(xlValue).MajorUnit = ylim(2)  ' 刻み
        .Axes(xlValue).TickLabels.NumberFormat = "0" ' 数値の表示形式 少数点以下の桁数を指定できます。

    ' ----- 軸の交点 ----- '
        .Axes(xlCategory).CrossesAt = xlim(0) ' 横軸の交点
        .Axes(xlValue).CrossesAt = ylim(0) ' 縦軸の交点

    ' ----- 軸の反転 ----- '
        .Axes(xlCategory).ReversePlotOrder = False ' 横軸
        .Axes(xlValue).ReversePlotOrder = False ' 縦軸
    End With
End Function

Function setFonts(ByVal FontName As String, ByVal FontSize As Integer)

    With ActiveChart
        ' ----- フォントとフォントサイズ ----- '
        .ChartTitle.Font.name = FontName ' タイトルのフォント
        .ChartTitle.Font.Size = FontSize + 3 ' タイトルのフォントサイズ
        .Axes(xlCategory).AxisTitle.Font.name = FontName ' 横軸名のフォント
        .Axes(xlCategory).AxisTitle.Font.Size = FontSize ' 横軸名のフォントサイズ
        .Axes(xlValue).AxisTitle.Font.name = FontName ' 縦軸名のフォント
        .Axes(xlValue).AxisTitle.Font.Size = FontSize ' 縦軸名のフォントサイズ
        .Axes(xlCategory).TickLabels.Font.name = FontName ' 横軸スケールのフォント
        .Axes(xlCategory).TickLabels.Font.Size = FontSize ' 横軸スケールのフォントサイズ
        .Axes(xlValue).TickLabels.Font.name = FontName ' 縦軸スケールのフォント
        .Axes(xlValue).TickLabels.Font.Size = FontSize ' 縦軸スケールのフォントサイズ|
        .Legend.Font.name = FontName ' 凡例のフォント
        .Legend.Font.Size = FontSize ' 凡例のフォントサイズ
    End With

End Function

Function setLegends(ByVal legends As Variant)
    With ActiveChart
        .HasLegend = True
        For iLegend = 1 To .SeriesCollection.Count
            .SeriesCollection(iLegend).name = legends(iLegend - 1)
        Next iLegend
        .Legend.Top = 20 * .SeriesCollection.Count
        .Legend.Left = .ChartArea.width * 0.8
        .Legend.Interior.Color = RGB(255, 255, 255)
        .Legend.Border.Color = RGB(0, 0, 0)
        .Legend.Font.Color = RGB(0, 0, 0)
    End With
End Function

Function plotScatterGraph(ByVal withline As Boolean)

    Dim colors As Variant
    colors = Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(0, 0, 255))
    With ActiveChart
' ----- マーカー ----- '
    For iSeries = 1 To .SeriesCollection.Count
        .SeriesCollection(iSeries).MarkerSize = 5 ' サイズ 2~72
        .SeriesCollection(iSeries).MarkerStyle = xlMarkerStyleCircle ' 形状
        ' --------------------------------------------------------------- '
        ' ----- .SeriesCollection(1).MarkerStyle = xlMarkerStyle*** ----------------- '
        ' ----- 末尾の***はCircle, Dash, Diamond, Dot, Plus, Square, Star, Triangle, X --- '
        ' ----- ただし、Dotはサイズを大きくできないかもしれません。---------------- '
        ' --------------------------------------------------------------- '
        .SeriesCollection(iSeries).MarkerForegroundColor = colors(iSeries - 1) ' マーカーの色
        .SeriesCollection(iSeries).MarkerBackgroundColor = colors(iSeries - 1) ' マーカーの内側の色
        .SeriesCollection(iSeries).Format.Shadow.Style = msoShadowStyleInnerShadow '影を隠す
        .SeriesCollection(iSeries).Format.Shadow.Visible = False '影を消す

        ' plot Line
        If withline Then
            .SeriesCollection(iSeries).Border.LineStyle = xlContinuous
            .SeriesCollection(iSeries).Border.Color = colors(iSeries - 1)
        Else
        .SeriesCollection(iSeries).Border.LineStyle = xlNone
        End If

        .HasTitle = True ' タイトルなしにできます。
        .HasLegend = True ' 凡例無しにできます。
    Next iSeries
    
    End With
End Function

Sub createGraph()
    Set rng = Selection

    ' get 1st colums
    For i = 1 To rng.Rows.Count
        Debug.Print rng(i, 2)
    Next i

    Dim chartObj As ChartObject
    Set chartObj = ActiveSheet.ChartObjects.Add( _
                    10, 10, 600, 400)
    
    With chartObj.Chart

        .SetSourceData ActiveSheet.range( _
            rng(1, 2), rng(rng.Rows.Count, rng.Columns.Count) _
        ), xlColumns
    
        For i = 2 To rng.Columns.Count
            .SeriesCollection(i - 1).XValues = _
            range(rng(1, 1), rng(rng.Rows.Count, 1))
        Next i

        ' chart type
        .ChartType = xlXYScatterLinesNoMarkers

    End With

    chartObj.Select

    Call plotGraph.plot

End Sub

Sub changeLineColor()
    
    Dim colors As Variant
    colors = Array(RGB(220, 95, 87), _
                    RGB(220, 156, 87), _
                    RGB(220, 218, 87), _
                    RGB(161, 220, 87), _
                    RGB(100, 220, 87), _
                    RGB(87, 220, 136), _
                    RGB(87, 220, 197), _
                    RGB(87, 181, 220), _
                    RGB(87, 120, 220), _
                    RGB(116, 87, 220), _
                    RGB(177, 87, 220), _
                    RGB(220, 87, 202), _
                    RGB(220, 87, 140))

    With ActiveChart
    For iSeries = 1 To .SeriesCollection.Count
        .SeriesCollection(iSeries).MarkerSize = 5 ' サイズ 2~72
        .SeriesCollection(iSeries).MarkerStyle = xlMarkerStyleCircle ' 形状
        ' --------------------------------------------------------------- '
        ' ----- .SeriesCollection(1).MarkerStyle = xlMarkerStyle*** ----------------- '
        ' ----- 末尾の***はCircle, Dash, Diamond, Dot, Plus, Square, Star, Triangle, X --- '
        ' ----- ただし、Dotはサイズを大きくできないかもしれません。---------------- '
        ' --------------------------------------------------------------- '
        .SeriesCollection(iSeries).MarkerForegroundColor = colors(iSeries - 1) ' マーカーの色
        .SeriesCollection(iSeries).MarkerBackgroundColor = colors(iSeries - 1) ' マーカーの内側の色
        .SeriesCollection(iSeries).Format.Shadow.Style = msoShadowStyleInnerShadow '影を隠す
        .SeriesCollection(iSeries).Format.Shadow.Visible = False '影を消す

        ' plot Line
        If True Then
            .SeriesCollection(iSeries).Border.LineStyle = xlContinuous
            .SeriesCollection(iSeries).Border.Color = colors(iSeries - 1)
        Else
        .SeriesCollection(iSeries).Border.LineStyle = xlNone
        End If

        .HasTitle = True ' タイトルなしにできます。
        .HasLegend = True ' 凡例無しにできます。
    Next iSeries
    End With

End Sub

' 棒グラフの１〜３個目を黒にする
Sub changeBarPlot()
    With ActiveChart
        .SeriesCollection(1).Points(1).Interior.Color = RGB(0, 0, 0)
        .SeriesCollection(1).Points(2).Interior.Color = RGB(0, 0, 0)
        .SeriesCollection(1).Points(3).Interior.Color = RGB(0, 0, 0)
    End With
End Sub

' アクティブなシート内のChartObjectのプロットエリアを選択中のものと揃える
Sub SetPlotArea()
    Dim cht As ChartObject
    
    For Each cht In ActiveSheet.ChartObjects
        With ActiveChart.PlotArea
            cht.Chart.PlotArea.Left = .Left
            cht.Chart.PlotArea.Top = .Top
            cht.Chart.PlotArea.Width = .Width
            cht.Chart.PlotArea.Height = .Height
        End With
    Next
End Sub