汎用ステートメントをまとめた.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」