VBAコード一覧　※自分用メモ

※ VBAのコードを再利用するためにまとめた自分用メモです。後日整理します。

Applicationオブジェクト関連

画面の更新停止

' 画面の更新停止

Application.ScreenUpdating = False
 ' 処理
Application.ScreenUpdating = True

' 画面の更新停止

Application.ScreenUpdating = False

' 処理

Application.ScreenUpdating = True

確認メッセージの非表示

' 確認メッセージの非表示

Application.DisplayAlerts = False
 ' 処理
Application.DisplayAlerts = True

' 確認メッセージの非表示

Application.DisplayAlerts = False

' 処理

Application.DisplayAlerts = True

コピーモードの解除

' コピーモードの解除 

Application.CutCopyMode = False

' コピーモードの解除

Application.CutCopyMode = False

ファイル関連

同名ファイルチェック（Excel）

' 同名ファイルチェック

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

' 同名ファイルチェック

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）

' 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

' 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

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

ファイルの存在チェック

' ファイルの存在チェック

Dim BookPath1 As String: BookPath1 = ファイルのパス

If Dir(BookPath1) <> "" Then
    Set targetBook1 = Workbooks.Open(BookPath1)
  Else
    MsgBox BookPath1 & vbCrLf & "が存在しません"
End If

' ファイルの存在チェック

Dim BookPath1 As String: BookPath1 = ファイルのパス

If Dir(BookPath1) <> "" Then

Set targetBook1 = Workbooks.Open(BookPath1)

Else

MsgBox BookPath1 & vbCrLf & "が存在しません"

End If

ファイルの保存（Excel, PDF）

' 変数宣言

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

' 変数宣言

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

テーブル関連

テーブル

' テーブル追加（テーブル名付き）
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

' テーブル追加（テーブル名付き）

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

Sharepoint にリストとしてエクスポート

' Sharepoint にリストとしてエクスポート
ActiveSheet.ListObjects(1).Publish Array(サイト名, リスト名), False

' Sharepoint にリストとしてエクスポート

ActiveSheet.ListObjects(1).Publish Array(サイト名, リスト名), False

ユーザーフォーム関連

ユーザーフォーム

' ユーザーフォームを表示する
UserForm1.Show

' ユーザーフォームを閉じる
Unload Me

' ユーザーフォームを表示する

UserForm1.Show

' ユーザーフォームを閉じる

Unload Me

その他（あとで整理）

グループ化

' グループ化を開く（列）
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

' グループ化を閉じる（列）
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

' グループ化を開く（列）

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

' グループ化を閉じる（列）

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

Findメソッド

' A列から値で完全一致で検索　※Findは遅いから他がいいらしい（Matchとか）

Set rng = Range("A:A").Find(検索文字, LookIn:=xlValues, LookAt:=xlWhole)

If rng Is Nothing Then
　MsgBox "対象者のデータがありません。"
　Exit Sub
End If

' A列から値で完全一致で検索　※Findは遅いから他がいいらしい（Matchとか）

Set rng = Range("A:A").Find(検索文字, LookIn:=xlValues, LookAt:=xlWhole)

If rng Is Nothing Then

　MsgBox "対象者のデータがありません。"

　Exit Sub

End If

最終行の取得

' A列の最終行を取得

Dim row As Integer
row = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).row

' A列の最終行を取得

Dim row As Integer

row = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).row

月初・月末の取得

'今月
今月月初 = 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)