Excel VBA | Subプロシージャ（マクロ）の考え方

Private Sub txtInput_Change()
    Dim txt As String
    txt = txtInput.Text
    
    '文字数制限: 10文字以内
    If Len(txt) > 10 Then
        txtInput.Text = Left(txt, 10)
        txtInput.SelStart = 10
        lblMessage.Caption = "10文字までです"
        lblMessage.ForeColor = vbRed
    Else
        lblMessage.Caption = "入力OK"
        lblMessage.ForeColor = vbGreen
    End If
End Sub

Private Sub txtInput_Change()
    Dim txt As String
    txt = txtInput.Text
    
    '文字数制限: 10文字以内
    If Len(txt) > 10 Then
        txtInput.Text = Left(txt, 10)
        txtInput.SelStart = 10
        lblMessage.Caption = "10文字までです"
        lblMessage.ForeColor = vbRed
    Else
        lblMessage.Caption = "入力OK"
        lblMessage.ForeColor = vbGreen
    End If
End Sub

Sub MergeWorkbooks()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook, destWb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, pasteRow As Long
    
    folderPath = "C:\Data\" '統合フォルダ
    Set destWb = ThisWorkbook
    pasteRow = 2
    
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        On Error GoTo SkipFile
        Set wb = Workbooks.Open(folderPath & fileName)
        Set ws = wb.Sheets(1)
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        
        ws.Range("A2:Z" & lastRow).Copy destWb.Sheets(1).Cells(pasteRow, 1)
        pasteRow = pasteRow + lastRow - 1
        
        wb.Close False
SkipFile:
        fileName = Dir()
        On Error GoTo 0
    Loop
End Sub

Sub MergeWorkbooks()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook, destWb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, pasteRow As Long
    
    folderPath = "C:\Data\" '統合フォルダ
    Set destWb = ThisWorkbook
    pasteRow = 2
    
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        On Error GoTo SkipFile
        Set wb = Workbooks.Open(folderPath & fileName)
        Set ws = wb.Sheets(1)
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        
        ws.Range("A2:Z" & lastRow).Copy destWb.Sheets(1).Cells(pasteRow, 1)
        pasteRow = pasteRow + lastRow - 1
        
        wb.Close False
SkipFile:
        fileName = Dir()
        On Error GoTo 0
    Loop
End Sub

'Class Module: clsData
Public DataArray() As String

Public Sub LoadCsv(filePath As String)
    Dim f As Integer, line As String, tmp() As String
    f = FreeFile
    Open filePath For Input As #f
    Dim i As Long: i = 0
    
    Do Until EOF(f)
        Line Input #f, line
        tmp = Split(line, ",")
        ReDim Preserve DataArray(i)
        DataArray(i) = Join(tmp, "|") '内部で配列を文字列に変換して格納
        i = i + 1
    Loop
    Close #f
End Sub

'Class Module: clsData
Public DataArray() As String

Public Sub LoadCsv(filePath As String)
    Dim f As Integer, line As String, tmp() As String
    f = FreeFile
    Open filePath For Input As #f
    Dim i As Long: i = 0
    
    Do Until EOF(f)
        Line Input #f, line
        tmp = Split(line, ",")
        ReDim Preserve DataArray(i)
        DataArray(i) = Join(tmp, "|") '内部で配列を文字列に変換して格納
        i = i + 1
    Loop
    Close #f
End Sub

'標準モジュール
Sub TestCsvClass()
    Dim obj As New clsData
    obj.LoadCsv "C:\Data\sample.csv"
    MsgBox "行数: " & UBound(obj.DataArray) + 1
End Sub

'標準モジュール
Sub TestCsvClass()
    Dim obj As New clsData
    obj.LoadCsv "C:\Data\sample.csv"
    MsgBox "行数: " & UBound(obj.DataArray) + 1
End Sub

Sub GetDataFromSQL()
    Dim conn As Object, rs As Object
    Dim sql As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=SQLOLEDB;Data Source=SERVER;Initial Catalog=DB;User ID=USER;Password=PWD;"
    
    sql = "SELECT TOP 10 * FROM Sales"
    Set rs = conn.Execute(sql)
    
    ws.Range("A1").CopyFromRecordset rs
    
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

Sub GetDataFromSQL()
    Dim conn As Object, rs As Object
    Dim sql As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=SQLOLEDB;Data Source=SERVER;Initial Catalog=DB;User ID=USER;Password=PWD;"
    
    sql = "SELECT TOP 10 * FROM Sales"
    Set rs = conn.Execute(sql)
    
    ws.Range("A1").CopyFromRecordset rs
    
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

Public Event DataChanged(ByVal value As Variant)

Private mValue As Variant

Public Property Let Value(val As Variant)
    mValue = val
    RaiseEvent DataChanged(mValue)
End Property

Public Property Get Value() As Variant
    Value = mValue
End Property

Public Event DataChanged(ByVal value As Variant)

Private mValue As Variant

Public Property Let Value(val As Variant)
    mValue = val
    RaiseEvent DataChanged(mValue)
End Property

Public Property Get Value() As Variant
    Value = mValue
End Property

Dim obj As clsObservable

Sub TestEvent()
    Set obj = New clsObservable
    'イベントハンドラをセット
    With obj
        'イベントハンドラを利用する場合は WithEvents で宣言した変数を UserForm や Class で扱う
        .Value = 100  '値をセットするとイベントが発生
    End With
End Sub

Dim obj As clsObservable

Sub TestEvent()
    Set obj = New clsObservable
    'イベントハンドラをセット
    With obj
        'イベントハンドラを利用する場合は WithEvents で宣言した変数を UserForm や Class で扱う
        .Value = 100  '値をセットするとイベントが発生
    End With
End Sub

Sub CreateChart()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=300, Width:=400, Top:=50, Height:=250)
    
    With chartObj.Chart
        .ChartType = xlColumnClustered
        .SetSourceData Source:=ws.Range("A1:B6")
        .HasTitle = True
        .ChartTitle.Text = "売上グラフ"
        .Axes(xlCategory).HasTitle = True
        .Axes(xlCategory).AxisTitle.Text = "商品"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "売上"
        .SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(0, 112, 192)
    End With
End Sub

Sub CreateChart()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=300, Width:=400, Top:=50, Height:=250)
    
    With chartObj.Chart
        .ChartType = xlColumnClustered
        .SetSourceData Source:=ws.Range("A1:B6")
        .HasTitle = True
        .ChartTitle.Text = "売上グラフ"
        .Axes(xlCategory).HasTitle = True
        .Axes(xlCategory).AxisTitle.Text = "商品"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "売上"
        .SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(0, 112, 192)
    End With
End Sub

Sub AutoConditionalFormat()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    'クリア
    ws.Cells.FormatConditions.Delete
    
    '数値 > 1000 赤文字
    ws.Range("B2:B100").FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="1000"
    ws.Range("B2:B100").FormatConditions(ws.Range("B2:B100").FormatConditions.Count).Font.Color = vbRed
    
    '文字列に "完了" が含まれる 緑背景
    ws.Range("C2:C100").FormatConditions.Add Type:=xlTextString, String:="完了", TextOperator:=xlContains
    ws.Range("C2:C100").FormatConditions(ws.Range("C2:C100").FormatConditions.Count).Interior.Color = vbGreen
End Sub

Sub AutoConditionalFormat()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    'クリア
    ws.Cells.FormatConditions.Delete
    
    '数値 > 1000 赤文字
    ws.Range("B2:B100").FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="1000"
    ws.Range("B2:B100").FormatConditions(ws.Range("B2:B100").FormatConditions.Count).Font.Color = vbRed
    
    '文字列に "完了" が含まれる 緑背景
    ws.Range("C2:C100").FormatConditions.Add Type:=xlTextString, String:="完了", TextOperator:=xlContains
    ws.Range("C2:C100").FormatConditions(ws.Range("C2:C100").FormatConditions.Count).Interior.Color = vbGreen
End Sub

Sub DisplayHierarchy()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    Dim id As String, parent As String, name As String
    Dim indent As String
    
    For i = 2 To lastRow
        id = ws.Cells(i, 1).Value
        parent = ws.Cells(i, 2).Value
        name = ws.Cells(i, 3).Value
        
        indent = String(Len(parent) * 2, " ")
        Debug.Print indent & name
    Next i
End Sub

Sub DisplayHierarchy()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    Dim id As String, parent As String, name As String
    Dim indent As String
    
    For i = 2 To lastRow
        id = ws.Cells(i, 1).Value
        parent = ws.Cells(i, 2).Value
        name = ws.Cells(i, 3).Value
        
        indent = String(Len(parent) * 2, " ")
        Debug.Print indent & name
    Next i
End Sub

'標準モジュール modUtils
Public Function IsEven(n As Long) As Boolean
    IsEven = (n Mod 2 = 0)
End Function

Public Function SafeDivide(a As Double, b As Double) As Double
    If b = 0 Then
        SafeDivide = 0
    Else
        SafeDivide = a / b
    End If
End Function

'標準モジュール modUtils
Public Function IsEven(n As Long) As Boolean
    IsEven = (n Mod 2 = 0)
End Function

Public Function SafeDivide(a As Double, b As Double) As Double
    If b = 0 Then
        SafeDivide = 0
    Else
        SafeDivide = a / b
    End If
End Function

Sub TestUtils()
    MsgBox "4は偶数? " & IsEven(4)
    MsgBox "10 ÷ 0 = " & SafeDivide(10, 0)
End Sub

Sub TestUtils()
    MsgBox "4は偶数? " & IsEven(4)
    MsgBox "10 ÷ 0 = " & SafeDivide(10, 0)
End Sub

Sub SendMail()
    Dim olApp As Object, olMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Set olApp = CreateObject("Outlook.Application")
    
    For i = 2 To lastRow
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = ws.Cells(i, 1).Value
            .Subject = ws.Cells(i, 2).Value
            .Body = ws.Cells(i, 3).Value
            
            If Dir(ws.Cells(i, 4).Value) <> "" Then
                .Attachments.Add ws.Cells(i, 4).Value
            End If
            
            .Send
        End With
    Next i
End Sub

Sub SendMail()
    Dim olApp As Object, olMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Set olApp = CreateObject("Outlook.Application")
    
    For i = 2 To lastRow
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = ws.Cells(i, 1).Value
            .Subject = ws.Cells(i, 2).Value
            .Body = ws.Cells(i, 3).Value
            
            If Dir(ws.Cells(i, 4).Value) <> "" Then
                .Attachments.Add ws.Cells(i, 4).Value
            End If
            
            .Send
        End With
    Next i
End Sub

Sub AnalyzeWorkbookDependencies()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets.Add
    ws.Name = "依存関係"
    
    ws.Cells(1, 1).Value = "シート名"
    ws.Cells(1, 2).Value = "参照セル"
    
    Dim r As Long: r = 2
    Dim sh As Worksheet
    
    For Each sh In wb.Sheets
        lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
        For i = 1 To lastRow
            If InStr(sh.Cells(i, 1).Formula, "[") > 0 Then
                ws.Cells(r, 1).Value = sh.Name
                ws.Cells(r, 2).Value = sh.Cells(i, 1).Formula
                r = r + 1
            End If
        Next i
    Next sh
End Sub

Sub AnalyzeWorkbookDependencies()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets.Add
    ws.Name = "依存関係"
    
    ws.Cells(1, 1).Value = "シート名"
    ws.Cells(1, 2).Value = "参照セル"
    
    Dim r As Long: r = 2
    Dim sh As Worksheet
    
    For Each sh In wb.Sheets
        lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
        For i = 1 To lastRow
            If InStr(sh.Cells(i, 1).Formula, "[") > 0 Then
                ws.Cells(r, 1).Value = sh.Name
                ws.Cells(r, 2).Value = sh.Cells(i, 1).Formula
                r = r + 1
            End If
        Next i
    Next sh
End Sub

Sub SplitLargeData()
    Dim ws As Worksheet, newWs As Worksheet
    Dim lastRow As Long, i As Long, batch As Long
    Dim rowsPerSheet As Long
    
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    rowsPerSheet = 10000
    batch = 1
    
    For i = 2 To lastRow Step rowsPerSheet
        Set newWs = ThisWorkbook.Sheets.Add
        newWs.Name = "Batch" & batch
        ws.Rows(1).Copy newWs.Rows(1) 'ヘッダーコピー
        ws.Rows(i & ":" & Application.Min(i + rowsPerSheet - 1, lastRow)).Copy newWs.Rows(2)
        batch = batch + 1
    Next i
End Sub

Sub SplitLargeData()
    Dim ws As Worksheet, newWs As Worksheet
    Dim lastRow As Long, i As Long, batch As Long
    Dim rowsPerSheet As Long
    
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    rowsPerSheet = 10000
    batch = 1
    
    For i = 2 To lastRow Step rowsPerSheet
        Set newWs = ThisWorkbook.Sheets.Add
        newWs.Name = "Batch" & batch
        ws.Rows(1).Copy newWs.Rows(1) 'ヘッダーコピー
        ws.Rows(i & ":" & Application.Min(i + rowsPerSheet - 1, lastRow)).Copy newWs.Rows(2)
        batch = batch + 1
    Next i
End Sub

Sub CreatePivot()
    Dim wsData As Worksheet, wsPivot As Worksheet
    Dim ptCache As PivotCache, pt As PivotTable
    Dim lastRow As Long, lastCol As Long
    
    Set wsData = ThisWorkbook.Sheets(1)
    Set wsPivot = ThisWorkbook.Sheets.Add
    wsPivot.Name = "PivotTable"
    
    lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
    lastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    
    Set ptCache = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=wsData.Range(wsData.Cells(1, 1), wsData.Cells(lastRow, lastCol)))
    
    Set pt = ptCache.CreatePivotTable(wsPivot.Cells(1, 1), "SalesPivot")
    
    pt.PivotFields("Category").Orientation = xlRowField
    pt.PivotFields("Amount").Orientation = xlDataField
    pt.PivotFields("Amount").Function = xlSum
End Sub

Sub CreatePivot()
    Dim wsData As Worksheet, wsPivot As Worksheet
    Dim ptCache As PivotCache, pt As PivotTable
    Dim lastRow As Long, lastCol As Long
    
    Set wsData = ThisWorkbook.Sheets(1)
    Set wsPivot = ThisWorkbook.Sheets.Add
    wsPivot.Name = "PivotTable"
    
    lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
    lastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    
    Set ptCache = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=wsData.Range(wsData.Cells(1, 1), wsData.Cells(lastRow, lastCol)))
    
    Set pt = ptCache.CreatePivotTable(wsPivot.Cells(1, 1), "SalesPivot")
    
    pt.PivotFields("Category").Orientation = xlRowField
    pt.PivotFields("Amount").Orientation = xlDataField
    pt.PivotFields("Amount").Function = xlSum
End Sub

Sub ExtractPattern()
    Dim regEx As Object, matches As Object
    Dim txt As String, i As Long
    
    txt = "商品123-AB, 商品456-CD, 商品789-EF"
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "商品\d{3}-[A-Z]{2}"
    regEx.Global = True
    
    If regEx.Test(txt) Then
        Set matches = regEx.Execute(txt)
        For i = 0 To matches.Count - 1
            Debug.Print matches(i)
        Next i
    End If
End Sub

Sub ExtractPattern()
    Dim regEx As Object, matches As Object
    Dim txt As String, i As Long
    
    txt = "商品123-AB, 商品456-CD, 商品789-EF"
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "商品\d{3}-[A-Z]{2}"
    regEx.Global = True
    
    If regEx.Test(txt) Then
        Set matches = regEx.Execute(txt)
        For i = 0 To matches.Count - 1
            Debug.Print matches(i)
        Next i
    End If
End Sub

Sub GetJsonFromAPI()
    Dim http As Object, JSON As Object
    Dim url As String
    url = "https://api.example.com/data"
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send
    
    If http.Status = 200 Then
        Dim resp As String
        resp = http.responseText
        
        'JSON パース（VBA-JSON 参照設定必須）
        Set JSON = JsonConverter.ParseJson(resp)
        Debug.Print JSON("data")(1)("name")
    Else
        MsgBox "通信エラー: " & http.Status
    End If
End Sub

Sub GetJsonFromAPI()
    Dim http As Object, JSON As Object
    Dim url As String
    url = "https://api.example.com/data"
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send
    
    If http.Status = 200 Then
        Dim resp As String
        resp = http.responseText
        
        'JSON パース（VBA-JSON 参照設定必須）
        Set JSON = JsonConverter.ParseJson(resp)
        Debug.Print JSON("data")(1)("name")
    Else
        MsgBox "通信エラー: " & http.Status
    End If
End Sub

Sub LogMessage(level As String, msg As String)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Log")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    ws.Cells(lastRow, 1).Value = Now
    ws.Cells(lastRow, 2).Value = level
    ws.Cells(lastRow, 3).Value = msg
    
    'レベル別色付け
    Select Case level
        Case "INFO": ws.Rows(lastRow).Interior.Color = RGB(220, 230, 241)
        Case "WARN": ws.Rows(lastRow).Interior.Color = RGB(255, 255, 153)
        Case "ERROR": ws.Rows(lastRow).Interior.Color = RGB(255, 153, 153)
    End Select
End Sub

Sub TestLog()
    LogMessage "INFO", "処理開始"
    LogMessage "WARN", "注意: データ欠損"
    LogMessage "ERROR", "エラー発生"
End Sub

Sub LogMessage(level As String, msg As String)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Log")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    
    ws.Cells(lastRow, 1).Value = Now
    ws.Cells(lastRow, 2).Value = level
    ws.Cells(lastRow, 3).Value = msg
    
    'レベル別色付け
    Select Case level
        Case "INFO": ws.Rows(lastRow).Interior.Color = RGB(220, 230, 241)
        Case "WARN": ws.Rows(lastRow).Interior.Color = RGB(255, 255, 153)
        Case "ERROR": ws.Rows(lastRow).Interior.Color = RGB(255, 153, 153)
    End Select
End Sub

Sub TestLog()
    LogMessage "INFO", "処理開始"
    LogMessage "WARN", "注意: データ欠損"
    LogMessage "ERROR", "エラー発生"
End Sub

'UserForm: frmSearch
'Controls: txtSearch (TextBox), lstResult (ListBox)

Private dataArr() As String

Public Sub LoadData()
    Dim ws As Worksheet, lastRow As Long, i As Long
    Set ws = ThisWorkbook.Sheets(1)
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    ReDim dataArr(1 To lastRow - 1)
    
    For i = 2 To lastRow
        dataArr(i - 1) = ws.Cells(i, 1).Value
    Next i
    
    Call FilterList("")
End Sub

Private Sub txtSearch_Change()
    Call FilterList(txtSearch.Text)
End Sub

Private Sub FilterList(keyword As String)
    Dim i As Long
    lstResult.Clear
    For i = LBound(dataArr) To UBound(dataArr)
        If keyword = "" Or InStr(dataArr(i), keyword) > 0 Then
            lstResult.AddItem dataArr(i)
        End If
    Next i
End Sub

'UserForm: frmSearch
'Controls: txtSearch (TextBox), lstResult (ListBox)

Private dataArr() As String

Public Sub LoadData()
    Dim ws As Worksheet, lastRow As Long, i As Long
    Set ws = ThisWorkbook.Sheets(1)
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    ReDim dataArr(1 To lastRow - 1)
    
    For i = 2 To lastRow
        dataArr(i - 1) = ws.Cells(i, 1).Value
    Next i
    
    Call FilterList("")
End Sub

Private Sub txtSearch_Change()
    Call FilterList(txtSearch.Text)
End Sub

Private Sub FilterList(keyword As String)
    Dim i As Long
    lstResult.Clear
    For i = LBound(dataArr) To UBound(dataArr)
        If keyword = "" Or InStr(dataArr(i), keyword) > 0 Then
            lstResult.AddItem dataArr(i)
        End If
    Next i
End Sub

Sub AutoBackup()
    Dim backupPath As String
    backupPath = "C:\Backup\"
    
    Dim fileName As String
    fileName = ThisWorkbook.Name
    fileName = Left(fileName, InStrRev(fileName, ".") - 1) & "_" & Format(Now, "yyyymmdd_hhnnss") & ".xlsm"
    
    ThisWorkbook.SaveCopyAs backupPath & fileName
End Sub

Sub ScheduleBackup()
    Application.OnTime Now + TimeValue("00:30:00"), "AutoBackup"
End Sub

Sub AutoBackup()
    Dim backupPath As String
    backupPath = "C:\Backup\"
    
    Dim fileName As String
    fileName = ThisWorkbook.Name
    fileName = Left(fileName, InStrRev(fileName, ".") - 1) & "_" & Format(Now, "yyyymmdd_hhnnss") & ".xlsm"
    
    ThisWorkbook.SaveCopyAs backupPath & fileName
End Sub

Sub ScheduleBackup()
    Application.OnTime Now + TimeValue("00:30:00"), "AutoBackup"
End Sub

Sub CreateModuleWithTemplate()
    Dim vbProj As Object, vbComp As Object
    Dim code As String
    
    Set vbProj = ThisWorkbook.VBProject
    Set vbComp = vbProj.VBComponents.Add(1) '標準モジュール
    
    vbComp.Name = "modAutoGenerated"
    
    code = "Sub AutoGeneratedSub()" & vbCrLf & _
           "    MsgBox ""自動生成コードです""" & vbCrLf & _
           "End Sub"
    
    vbComp.CodeModule.AddFromString code
End Sub

Sub CreateModuleWithTemplate()
    Dim vbProj As Object, vbComp As Object
    Dim code As String
    
    Set vbProj = ThisWorkbook.VBProject
    Set vbComp = vbProj.VBComponents.Add(1) '標準モジュール
    
    vbComp.Name = "modAutoGenerated"
    
    code = "Sub AutoGeneratedSub()" & vbCrLf & _
           "    MsgBox ""自動生成コードです""" & vbCrLf & _
           "End Sub"
    
    vbComp.CodeModule.AddFromString code
End Sub

Sub AnalyzeData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim arr() As Double, lastRow As Long, i As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    ReDim arr(1 To lastRow - 1)
    
    For i = 2 To lastRow
        arr(i - 1) = ws.Cells(i, 1).Value
    Next i
    
    Dim sumVal As Double, avgVal As Double, varVal As Double
    Dim maxVal As Double, minVal As Double
    
    sumVal = WorksheetFunction.Sum(arr)
    avgVal = WorksheetFunction.Average(arr)
    varVal = WorksheetFunction.Var(arr)
    maxVal = WorksheetFunction.Max(arr)
    minVal = WorksheetFunction.Min(arr)
    
    ws.Cells(1, 3).Value = "合計": ws.Cells(2, 3).Value = sumVal
    ws.Cells(1, 4).Value = "平均": ws.Cells(2, 4).Value = avgVal
    ws.Cells(1, 5).Value = "分散": ws.Cells(2, 5).Value = varVal
    ws.Cells(1, 6).Value = "最大": ws.Cells(2, 6).Value = maxVal
    ws.Cells(1, 7).Value = "最小": ws.Cells(2, 7).Value = minVal
End Sub

Sub AnalyzeData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim arr() As Double, lastRow As Long, i As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    ReDim arr(1 To lastRow - 1)
    
    For i = 2 To lastRow
        arr(i - 1) = ws.Cells(i, 1).Value
    Next i
    
    Dim sumVal As Double, avgVal As Double, varVal As Double
    Dim maxVal As Double, minVal As Double
    
    sumVal = WorksheetFunction.Sum(arr)
    avgVal = WorksheetFunction.Average(arr)
    varVal = WorksheetFunction.Var(arr)
    maxVal = WorksheetFunction.Max(arr)
    minVal = WorksheetFunction.Min(arr)
    
    ws.Cells(1, 3).Value = "合計": ws.Cells(2, 3).Value = sumVal
    ws.Cells(1, 4).Value = "平均": ws.Cells(2, 4).Value = avgVal
    ws.Cells(1, 5).Value = "分散": ws.Cells(2, 5).Value = varVal
    ws.Cells(1, 6).Value = "最大": ws.Cells(2, 6).Value = maxVal
    ws.Cells(1, 7).Value = "最小": ws.Cells(2, 7).Value = minVal
End Sub