VBA：Excel VBA ：Tips

ブックを開く

Sub openBook()

    Dim ap As Application   'Excelの情報、処理
    Dim wb As Workbook      '単独Bookの情報、処理
                            '：全book情報は、上位のBooksコレクション
    
    Dim ws As Worksheet     '単独Sheetuの情報、処理
                            '：全Sheet情報は、上位のSheetsコレクション
    
    Dim rg As Range
    
    Set ap = Application
    
    For Each wb In ap.Workbooks
        Debug.Print (wb.Name)
    Next

    '新しいブックの作成：add
    '⇒ ワークブックコレクションに追加 ⇒ 開く
    ap.Workbooks.Add
    
    
    '指定ブックを開きます:Open
    '-- Openするとき
    Set wb = ap.Workbooks.Open("D:\_New.xlsx")
    For Each ws In wb.Sheets
        Debug.Print (ws.Name)
    Next
    
    '-- Openしているとき
    Dim wb2 As Workbook
    Set wb2 = ap.Workbooks("_New.xlsx")
    
    For Each ws2 In wb2.Sheets
        Debug.Print (ws2.Name)
    Next
    
    Set wb2 = Nothing
    Set wb = Nothing
    Set ap = Nothing
    
    
End Sub

OPEN／CLOSE 処理

ThisWorkbook
Private Sub Workbook_Open()
　　'処理を記述
End Sub

ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
　　'処理を記述
End Sub

ワークシート関数

SUM

Sub wf_sum()
    Dim wf As WorksheetFunction
    Set wf = WorksheetFunction
        
    Range("A6") = wf.Sum(Range("A1:a5"))
    
End Sub

COUNTIF ／ SUMIF

Sub wf_countif_sumif()

    Dim wf As WorksheetFunction
    Set wf = WorksheetFunction
        
    '「A11:A16」から「A」をCount
    Range("E16") = wf.CountIf(Range("A11:A16"), "A")
    
    '「A11:A16」から「A」の「B11:B16」をSUM
    Range("F16") = wf.SumIf(Range("A11:A16"), "A", Range("B11:B16"))

End Sub

配列

セル <---> 配列　一括 読込み／書出し／行列変換 書出し

'********************************************
' 配列 <--> セル
'　・読込み／書出し／行列変換書出し
'
'********************************************
Private Sub btn_セルto配列2D_Click()

    '//############################################
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("TEST")
    '//############################################
    
    '---------------------------------------------------
    '// 読込み　（3列想定）
    '---------------------------------------------------
    
    Dim lLast_Row As Long
    Dim lLast_Col As Long
    
    lLast_Row = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lLast_Col = Cells(1, Columns.Count).End(xlToLeft).Column
    
    ws.Range(Columns(4), Columns(lLast_Col)).Clear
    
    'セル範囲一括取得
    '※要素は「1」から開始（vArr2D(1,1)～）
    Dim vArr2D() As Variant
    
    vArr2D = ws.Range(Cells(1, 1), Cells(lLast_Row, lLast_Col))
    
    '---------------------------------------------------
    '// 書出し
    '---------------------------------------------------
    Dim lRow As Long: lRow = UBound(vArr2D, 1) - LBound(vArr2D, 1) + 1
    Dim lCol As Long: lCol = UBound(vArr2D, 2) - LBound(vArr2D, 2) + 1
   
    ws.Range(Cells(1, 5), Cells(lRow, lCol + 5 - 1)).Value = vArr2D
    ws.Range(Columns(4), Columns(lLast_Col + 1)).Clear

    '---------------------------------------------------
    '// 行列変換
    '---------------------------------------------------
    Dim lvArr_Row As Long: lvArr_Row = UBound(vArr2D, 1) - LBound(vArr2D, 1) + 1
    Dim lvArr_Col As Long: lvArr_Col = UBound(vArr2D, 2) - LBound(vArr2D, 2) + 1
    
    Dim rng As Range
    'Set rng = ws.Range(Cells(1, 5), Cells(lvArr_Col, lvArr_Row)) '// <-- 行列変換
    Set rng = ws.Range("E1", Cells(lvArr_Col, lvArr_Row)) '// <-- 行列変換
    
    rng.Value = WorksheetFunction.Transpose(vArr2D)
    Set rng = Nothing
    
    
    '//############################################
    Set ws = Nothing
    '//############################################

End Sub

名前付き範囲

設定／確認／削除／先頭・最終－アドレス・番号

'********************************************
' 名前付き範囲
'
'********************************************
Private Sub btn_名前付き範囲_Click()

    '//############################################
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("TEST")
    '//############################################
    
    Dim rng As Range
    Set rng = ws.Range("A1", "D5")
    rng.Select
    
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    ' 設定
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'Worksheets(“シート名”).Names.Add [Name ,RefersTo ,RefersToR1C1 ,Visible ,MacroType]
    ThisWorkbook.Worksheets(rng.Parent.Name).Names.Add "lst_test", rng, True, 3
    
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    ' 確認
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Dim vItem As Variant
    For Each vItem In ThisWorkbook.Names
        Debug.Print vItem.Name
    Next
    
    '-------------------------------
    '　先頭行
    '-------------------------------
    Set rng = Range("lst_test").Rows(1)
    rng.Select
    MsgBox rng.Address(False, False)
    MsgBox "行番号 = " & rng.Row
    
    '-------------------------------
    '　先頭列
    '-------------------------------
    Set rng = Range("lst_test").Columns(1)
    rng.Select
    MsgBox rng.Address(False, False)
    MsgBox "列番号 = " & rng.Column
    MsgBox "列文字 = " & mth_列アドレス_数値文字変換(rng.Column)
    
    '-------------------------------
    '　最終行
    '-------------------------------
    Dim rng_Last_Row As Range
    
    Set rng = Range("lst_test")
    rng.Select
    Set rng_Last_Row = rng.Rows(rng.Rows.Count).EntireRow
    MsgBox rng_Last_Row.Address(False, False)
    MsgBox "行番号 = " & rng_Last_Row.Row
    
    '-------------------------------
    '　最終列
    '-------------------------------
    Dim rng_Last_Col As Range
    
    Set rng = Range("lst_test")
    rng.Select
    Set rng_Last_Col = rng.Columns(rng.Columns.Count).EntireColumn
    MsgBox rng_Last_Col.Address(False, False)
    MsgBox "列番号 = " & rng_Last_Col.Column
    MsgBox "列文字 = " & mth_列アドレス_数値文字変換(rng_Last_Col.Column)
    
    
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    ' 削除
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    For Each vItem In ThisWorkbook.Names
        Debug.Print vItem.Name
        If vItem.Visible = True Then
            Application.Names.Item(vItem.Name).Delete
        End If
        
    Next
    
    
    Set rng = Nothing
    '//############################################
    Set ws = Nothing
    '//############################################

End Sub

シートの保護設定

設定／解除

'********************************************
' シートの保護設定
'   https://www.officepro.jp/excelvba/sheet_ope/index2.html
'
'********************************************
Private Sub btn_シートの保護設定_Click()

    '//############################################
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("TEST")
    '//############################################
    Dim vItem As Variant

    '---------------------
    ' 設定
    '---------------------
    For Each vItem In ThisWorkbook.Worksheets
        vItem.Protect _
                    Password:="pass", _
                    UserInterfaceOnly:=True, _
                    AllowFiltering:=True, _
                    AllowFormattingCells:=True, _
                    AllowFormattingColumns:=True, _
                    AllowFormattingRows:=True


    Next
    
    '---------------------
    ' 解除
    '---------------------
    For Each vItem In ThisWorkbook.Worksheets
        vItem.Unprotect Password:="pass"
    Next

    
    '//############################################
    Set ws = Nothing
    '//############################################


End Sub


Function mth_列アドレス_数値文字変換(lCol As Long) As String

    Dim sBuf As String
    
    sBuf = Cells(1, lCol).Address(True, False) '列のみ相対参照 (ex)A$1
    sBuf = Left(sBuf, InStr(sBuf, "$") - 1)

    
    mth_列アドレス_数値文字変換 = sBuf
    
End Function

セル 列番地 文字<---> 数値 変換

'********************************************
' 列：数値 <---> 文字 変換
'
'********************************************
Private Sub btn_セル番地_列文字変換_Click()

    '//############################################
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("TEST")
    '//############################################
    
    
    Dim lCol As Integer: lCol = 10
    ws.Cells(1, lCol).Select
    
    Dim sBuf As String
    sBuf = ws.Cells(1, lCol).Address(True, False) '列のみ相対参照 (ex)A$1
    sBuf = Left(sBuf, InStr(sBuf, "$") - 1)
    Call MsgBox("列：文字 = " & sBuf)
    
    '---------------------
    ' 文字→数値
    '---------------------
    Dim lCol_Num As Long
    lCol_Num = Range(sBuf & "1").Column
    Call MsgBox("列：数値 = " & lCol_Num)
    
    '//############################################
    Set ws = Nothing
    '//############################################
    
End Sub

行／列

最終行／最終 列

    Cells(Rows.Count, 1).End(xlUp).Row
    Cells(1, Columns.Count).End(xlToLeft).Column

    Range("A" & Rows.Count).End(xlUp).Row

複数行／列 選択

' 行／列 選択
'
'********************************************
Private Sub btn_行列_複数行_Click()

    '//############################################
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("TEST")
    '//############################################
    Dim rng As Range
    
    Set rng = ws.Rows(3):     rng.Select
    Set rng = ws.Rows("6:8"): rng.Select
    Set rng = ws.Rows:       rng.Select
    
    '-------------------------------------------------
    '離れた行：Range
    '-------------------------------------------------
    Set rng = ws.Range("2:2,4:4,6:8")   '// 離れた行
    rng.EntireRow.Select
    
    '-------------------------------------------------
    '// EntireRow : 指定したセルの対象行全体
    '-------------------------------------------------
    Set rng = ws.Range("A2,A4,A6:A8")   '// 離れた行
    rng.EntireRow.Select

    '//===================================================
    Set rng = ws.Columns(3):     rng.Select
    Set rng = ws.Columns("A"):     rng.Select
    'Set rng = ws.Columns("6:8"): rng.Select    <-- NG
    Set rng = ws.Columns("C:D"): rng.Select
    Set rng = ws.Columns:        rng.Select
    
    '-------------------------------------------------
    '離れた列：Range
    '-------------------------------------------------
    Set rng = ws.Range("B:B,D:E")   '// 離れた行
    rng.Select
    
    '-------------------------------------------------
    '// EntireColumn : 指定したセルの対象列全体
    '-------------------------------------------------
    Set rng = ws.Range("C1,F1:H1")   '// 離れた行
    rng.EntireColumn.Select
    
    '//############################################
    Set rng = Nothing
    Set ws = Nothing
    '//############################################

End Sub