※ VBAのコードを再利用するためにまとめた自分用メモです。後日整理します。
目次
Applicationオブジェクト関連
画面の更新停止
1 2 3 4 5 6 |
' 画面の更新停止 Application.ScreenUpdating = False ' 処理 Application.ScreenUpdating = True |
確認メッセージの非表示
1 2 3 4 5 6 |
' 確認メッセージの非表示 Application.DisplayAlerts = False ' 処理 Application.DisplayAlerts = True |
コピーモードの解除
1 2 3 4 |
' コピーモードの解除 Application.CutCopyMode = False |
ファイル関連
同名ファイルチェック(Excel)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
' 同名ファイルチェック Dim wb As Workbook Dim BookPath1 As String: BookPath1 = ファイルのパス For Each wb In Workbooks If wb.Name = Dir(BookPath1) Then MsgBox Dir(BookPath1) & vbCrLf & "はすでに開いています", vbExclamation Exit Sub End If Next wb |
同名ファイルチェック(PDF)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
' PDFファイルを開いている場合のエラー解除(WordVBAで対応) Dim wd As Object Dim ts As Object Dim r As Long Dim p As Integer Set wd = CreateObject("Word.Application") r = 0 For Each ts In wd.Tasks p = InStr(ts, ".pdf") If ts.Visible = True And p > 0 Then r = r + 1 Cells(r, 60).Value = Mid(ts.Name, 1, p + 3) ' 60列目に出力 End If Next wd.Quit Set wd = Nothing ' 同名のPDFを開いていれば終了、開いていなければPDFで保存 If Cells(1, 60).Value = file_name Then MsgBox "ファイルを閉じてから再度実行してください。" Range("BH:BH").Clear ' 60列目をクリア Cells(Selection.row, 1).Select ' 左上に戻る(Ctrl + Home) Exit Sub Else Worksheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=folder & file_name End If |
ファイルの存在チェック
1 2 3 4 5 6 7 8 9 10 |
' ファイルの存在チェック Dim BookPath1 As String: BookPath1 = ファイルのパス If Dir(BookPath1) <> "" Then Set targetBook1 = Workbooks.Open(BookPath1) Else MsgBox BookPath1 & vbCrLf & "が存在しません" End If |
ファイルの保存(Excel, PDF)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
' 変数宣言 Dim targetBook1 As Workbook Dim BookPath1 As String: BookPath1 = ファイルのパス ' 保存先をデスクトップとするためパスを取得 Dim wsh As Object Set wsh = CreateObject("WScript.Shell") Dim folder As String: folder = wsh.SpecialFolders("Desktop") & "\" Dim file_name As String: file_name = ファイル名 & ".pdf" ' Excelで保存 targetBook1.SaveAs Filename:=BookPath1, FileFormat:=xlOpenXMLWorkbook ' PDFで保存 Worksheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=folder & file_name |
テーブル関連
テーブル
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
' テーブル追加(テーブル名付き) ActiveSheet.ListObjects.Add.Name = テーブル名 ' テーブル追加(スタイルなし) ActiveSheet.ListObjects(1).TableStyle = "" ' テーブル解除 ActiveSheet.ListObjects(1).Unlist ' 列の追加 With ActiveSheet With .ListObjects(1).ListColumns With .Add .Range(1).Value = 新規の列名 ' 1行目にヘッダー名 .Range(2).Formula = "=vlookup など" ' 2行目に関数を入れれば最終行まで反映 .DataBodyRange.Copy ' 2行目から最終行まで値貼り付け .DataBodyRange.PasteSpecial Paste:=xlPasteValues End With End With End With |
Sharepoint にリストとしてエクスポート
1 2 3 |
' Sharepoint にリストとしてエクスポート ActiveSheet.ListObjects(1).Publish Array(サイト名, リスト名), False |
ユーザーフォーム関連
ユーザーフォーム
1 2 3 4 5 6 |
' ユーザーフォームを表示する UserForm1.Show ' ユーザーフォームを閉じる Unload Me |
その他(あとで整理)
グループ化
1 2 3 4 5 6 |
' グループ化を開く(列) ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 ' グループ化を閉じる(列) ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 |
Findメソッド
1 2 3 4 5 6 7 8 9 |
' A列から値で完全一致で検索 ※Findは遅いから他がいいらしい(Matchとか) Set rng = Range("A:A").Find(検索文字, LookIn:=xlValues, LookAt:=xlWhole) If rng Is Nothing Then MsgBox "対象者のデータがありません。" Exit Sub End If |
最終行の取得
1 2 3 4 5 |
' A列の最終行を取得 Dim row As Integer row = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).row |
月初・月末の取得
1 2 3 4 5 6 7 8 9 10 11 12 |
'今月 今月月初 = DateSerial(Year(Date), Month(Date), 1) 今月月末 = DateSerial(Year(Date), Month(Date) + 1, 0) '先月 先月月初 = DateSerial(Year(Date), Month(Date) - 1, 1) 先月月末 = DateSerial(Year(Date), Month(Date), 0) '来月 来月月初 = DateSerial(Year(Date), Month(Date) + 1, 1) 来月月末 = DateSerial(Year(Date), Month(Date) + 2, 0) |