[自分メモ]ExcelVBA 汎用 ステートメント集

　汎用ステートメントをまとめた.txtを「あれ？　どこ置いたっけ・・・？」って毎回探している。OneDriveを探して社内サーバー探してドキュメント探してデスクトップ探して結局いつもOneDriveにある。いっそWebページに置いとけばいんじゃね？　って最近思った。

よく使うステートメント

共有ファイルオープン

'共有ファイルオープン
Dim ファイル名 As String
ファイル名 = "\\192.168.11.22\共有フォルダ\テスト.xlsm"
  '◆◆◆◆◆ファイルオープン◆◆◆◆◆
    Workbooks.Open ファイル名
  '◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆

Application.Wait Now() + TimeValue("00:00:01")    '1秒停止
'開いたのち、読み取り専用かどうかの確認。読み取り専用ならエラー。
If ActiveWorkbook.ReadOnly = True Then
        ActiveWorkbook.Close
        MsgBox ファイル名 & "　は他のユーザーが使用中だよ/( #'ω')/"
        Exit Sub
End If

◆最終行　取得

'◆最終行　取得
    lc = Cells(Rows.Count, 2).End(xlUp).Row
'◆最終列　取得
    lc = Cells(1, Columns.Count).End(xlToLeft).Column

改行

'改行
vbCrLf & _
"/( #'ω')/" & vbCrLf & _
"/( #'ω')/"

処理が重たい時

'VBAの処理が重たいとき
Application.ScreenUpdating = False '◆画面更新OFF
Application.DisplayStatusBar = False 'ステータスバーOFF
Application.EnableEvents = False 'イベントOFF
Application.Calculation = xlManual '関数再計算OFF

'処理

Application.ScreenUpdating = True '◆画面更新ON
Application.DisplayStatusBar = True 'ステータスバーON
Application.EnableEvents = True 'イベントON
Application.Calculation = xlAutomatic '関数再計算ON

ブックを閉じる

'◆ブックを閉じる
Set wb = ThisWorkbook

Application.DisplayAlerts = False
wb.Close
Application.Wait Now() + TimeValue("00:00:01")
Application.DisplayAlerts = True

Noで終了msgBox

'◆NOで終了
If MsgBox("/( #'ω')/", vbOKCancel) <> 1 Then
       Exit Sub
    End If

MsgBox 注意マーク

'◆注意メッセージ
MsgBox "/( #'ω')/", vbExclamation

シート保護ON/OFF

Public nowsheet As Worksheet
Public ALL_sheet As Worksheet

Sub 全シート保護ON()
Set nowsheet = ActiveSheet
For Each ALL_sheet In Worksheets
    ALL_sheet.Activate
    ALL_sheet.Protect
Next
nowsheet.Activate

End Sub

Sub 全シート保護OFF()

Set nowsheet = ActiveSheet
For Each ALL_sheet In Worksheets
    ALL_sheet.Activate
    ALL_sheet.Unprotect
Next
nowsheet.Activate

End Sub

データ並び替え

'◆並び替え　シート名指定するとなんか失敗するので対象シートをActivateしてから使おう。
〇〇.Activate
  Call Range("B8:H80").Sort( _
  Key1:=Range("B8"), _
  Order1:=xlAscending)

テーブルフィルター

'◆テーブルフィルター
Sub フィルター()
Range("A3").AutoFilter _
        Field:=5, Criteria1:=">0.00"
End Sub

テーブルフィルター解除

'◆テーブルフィルター解除
Sub フィルター解除()
Range("A3").AutoFilter
End Sub

上書き保存禁止

'◆上書き保存禁止。　シートオブジェクト内に記述。
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

If Not Sheets1.Cells(1 , "A") = "" Then
    Sheets1.Cells(1 , "A") = ""
    Exit Sub
End If

MsgBox "保存は禁止されています"
Cancel = True
End Sub

印刷

'印刷ボタン
Dim pli As String
Dim pNum As Integer
Dim PDF保存 As String

'プリンター名指定
'___/( #'ω')/______/( #'ω')/___
pli = "コントロールパネルに登録されているプリンター名"
'_/( #'ω')/_____/( #'ω')/______

If Not Cells(15, "G") = "" Then
    pNum = Cells(15, "G").Value   '特定セルの値の枚数印刷する。
Else
    pNum = 1
End if
'印刷処理。
  ActiveWindow.SelectedSheets.PrintOut ActivePrinter:=pli, Copies:=pNum, Collate:=True, _
    IgnorePrintAreas:=False
Cells(15, "G") = "1"    '印刷枚数リセット
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDF保存 '.pdf 生成

別の.xlsmを操作する時にマクロ無効処理

'別.xlsmをいじる時にマクロ無効にしたい時
Application.EnableEvents = False 'マクロイベントオフ
Application.EnableEvents = True 'マクロイベントオン

Countif関数で存在確認 戻り値は0 or 1以上

'CountIfで存在確認
dim i as long
dim chack as string
dim count as long

 chack = Cells(i, "C").Value'条件格納
 count = WorksheetFunction.CountIf(ws1.Range("A:A"), chack)'条件文字列 存在確認

UFをxボタンで閉じるの禁止

'ユーザーフォームを閉じる際に実行
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    If CloseMode = 0 Then
        MsgBox "ボタンで閉じてよね"
        '操作キャンセル
        Cancel = True
    End If
End Sub

UFを画面中央に表示(デュアルモニター用)

'**ユーザーフォームを親ウィンドウの中央に表示する
Private Sub UFPositionCenter()
  
  '**変数(T=Top,L=Left,W=Width,H=Height,AW=ActiveWindow,UF=UserForm)
  Dim T_AW As Long, L_AW As Long, W_AW As Long, H_AW As Long
  Dim T_UF As Long, L_UF As Long, W_UF As Long, H_UF As Long
  '**親ウィンドウの位置とサイズを取得
  With ActiveWindow
    T_AW = .Top
    L_AW = .Left
    W_AW = .Width
    H_AW = .Height
  End With
  '**UFのサイズを取得
  W_UF = Me.Width
  H_UF = Me.Height
  '**UFの表示位置を計算
  T_UF = T_AW + ((H_AW - H_UF) / 2)
  L_UF = L_AW + ((W_AW - W_UF) / 2)
  '**UFの表示位置を設定
  Me.StartUpPosition = 0
      '**Top,Left指定時に必須(ないとLeftがずれる)
  Me.Top = T_UF
  Me.Left = L_UF
End Sub

特定のセルをダブルクリックで処理開始

'シートobjに記述。ダブルクリックすると以下処理実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'' 対象列以外はスルー(念の為? 対象セルは単一セルとする)
If Intersect(Target, Range("L5", "L1000")) Is Nothing Then End
 コード = ActiveCell(1, 0).Value 'Target.Valueの一つ左
 ネーム = Target.Value
'処理を記述
End Sub

連想二次元配列(keyは一意 Itemは１つのみ)

'連想二次元配列

Dim myDict As Object '=Dictionary
Dim myDict_Item As String '配列アイテム
Dim tmp As Variant '配列アイテムのSplit用
Dim 履歴範囲 As Variant'配列生成用範囲
Dim myKey As Variant'アイテム格納
Dim i As Long'ループ
Dim p As Long'ループ２


Set myDict = CreateObject("Scripting.Dictionary") '連想二次元配列オブジェクト作成


lc = シート.Cells(Rows.Count, "A").End(xlUp).Row '履歴最終行
履歴範囲 = シート.Range("A1:F" & lc).Value  '履歴範囲取得

'配列格納
For i = 1 To UBound(履歴範囲, 1)
    If コード = 履歴範囲(i, 2) Then ' 捜索
        'アイテム作製
        myDict_Item = 履歴範囲(i, 1) & "_" & 履歴範囲(i, 4) & "_" & 履歴範囲(i, 5)
        Call myDict.Add(i, myDict_Item)           '配列に格納
    End If
Next

'配列の鍵(ループ数)を取得
myKey = myDict.Keys

'配列書き込み
シート.Activate
For i = 0 To UBound(myKey)
  tmp = Split(myDict.Item(myKey(i)), "_")
  p = i + 5
    シート.Cells(p, "B") = tmp(0)
    シート.Cells(p, "C") = tmp(1)
Next

'配列オブジェクトの破棄
Set myDict = Nothing

ファイル選択ダイアログ→ファイル名取得

Sub ファイル名取得()

    '変数filenameに選ばれたファイル名を取得
    Dim filename As String
    ChDrive "C"
    
    ChDir "C:\"
    'ファイル選択ダイアログの呼び出し
    filename = GetFileName("全てのファイル,*.*")
End Sub

Function GetFileName(filter As String) As String
 
    Dim fname_str As String
     
    'ファイル選択ダイアログの呼び出し
    fname_str = Application.GetOpenFilename(filter)
     
    If fname_str <> "False" Then
        '選択されたとき
        GetFileName = fname_str
    Else
        'キャンセルされたとき
        GetFileName = "Cancel"
    End If
     
End Function

その他備忘録

◆自作アドイン(.xlam)保存先。毎回忘れるのでここに記す。
C:\Users\Windows\AppData\Roaming\Microsoft\AddIns

◆構文エラースルー。うざいのでオフにする。
VBE→ツール→オプション→編集→コードの編集の「自動構文チェック」を外す




◆いつものシンタックスカラー
VBE→ツール→オプション→エディターの設定
フォント　メイリオ
サイズ　10
標準コード　黄色
コメント　　　黄緑
キーワード　水色
識別子　　　白

Excel関数
◆最終行可変Vlookup
=VLOOKUP(F1,INDIRECT("A1:E"&COUNTA(A:A)),3,0)
◆列重複入力禁止
リボン「データ」→［入力規則］→設定のユーザー設定→
「=COUNTIF(A:A,A1)=1」