ホーム
Excel VBA スニペット

Excel VBA スニペット

2019.07.06
a

フォームの開閉 

'Form01を開く
Form01.Show　'デフォルトでモーダル(vbModal)・・・閉じるまでExcel操作不可

Form01.Showvb Modeless　’Excel操作可能

'Form01を閉じる
Unload Form01

a

Do Until~Loop 

'条件を満たすまで　前判定
Dim n As Long
n = 1
Do Until n > 5
    Debug.Print n
    n = n + 1
Loop

'条件を満たすまで　後判定
n = 1
Do
    Debug.Print n
    n = n + 1
Loop Until n > 5
a

Do While～Loop 

'条件を満たす間まで　前判定
Dim n As Long
n = 1
Do While n < 5
    Debug.Print n
    n = n + 1
Loop

'条件を満たす間まで　後判定
n = 1
Do
    Debug.Print n
    n = n + 1
Loop While n < 5
a

表示形式 

’標準
Rangeオブジェクト.NumberFormatLocal = "G/標準"

'文字列
Rangeオブジェクト.NumberFormatLocal = "@"

’数値
Rangeオブジェクト.NumberFormatLocal = "0"
a

行と列の選択 

'行選択 2行目から3行目
Range("2:3").Select

'行選択 2行目から3行目
Rows("2:3").Select

'B列からC列
Range("B:C").Select

'B列からC列
Columns("B:C").Select
a

セル選択 

'セル範囲【B2:D3】
Range("B2:D3").Select
 
'セル範囲【B2:D3】
Range("B2", "D3").Select

'セル【B2】と【D3】
Range("B2,D3").Select

a

対象ブックが存在するか確認（Dir利用) 

'ブック確認
Sub 対象ブックが存在するか確認_D()
    Dim filePath As String
    filePath = "C:\Sample\Book1.xlsx"
    
     If Dir(filePath)  "" Then
        Debug.Print "存在する"
    Else
        Debug.Print "存在しない"
    End If
End Sub
a

対象ブックが存在するか確認（ファイルオブジェクト) 

Sub 対象ブックが存在するか確認_Fso()
    Dim fso As Object
    Dim filePath As String
    filePath = "C:\Sample\Book1.xlsx"
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FileExists(filePath) Then
        Debug.Print "存在する"
    Else
        Debug.Print "存在しない"
    End If
End Sub

a

シート存在確認 

Sub シートの存在確認()
    Dim ws As Worksheet
    Dim flag As Boolean
    For Each ws In Worksheets
        If ws.Name = "〇〇" Then
            flag = True
        End If
    Next ws
    If flag Then
        MsgBox "「〇〇」シートあり"
    Else
        MsgBox "「〇〇」シートなし"
    End If
End Sub
' シート存在確認
Public Function ExistsSheet( _
        ByVal sheetName As String, _
        Optional ByVal wb As Workbook = Nothing _
    ) As Boolean
    
    Dim ws As Worksheet
    
    If wb Is Nothing Then Set wb = ThisWorkbook
    
    For Each ws In wb.Worksheets
        If StrComp(ws.Name, sheetName, vbTextCompare) = 0 Then
            ExistsSheet = True
            Exit Function
        End If
    Next
    
    ExistsSheet = False
End Function
a

ブックが開かれているか確認 

Sub ブックが開いているか確認()
    Dim wb As Workbook
    Dim flag As Boolean
    For Each wb In Workbooks
        If wb.Name = "Book1.xlsx" Then
            flag = True
        End If
    Next wb
    If flag Then
        MsgBox "Book1 は開いている"
    Else
        MsgBox "Book1 は開いてない"
    End If
End Sub

a

ワークシートの移動 

'「temp」シートを末尾に移動
  Worksheets("temp").Move after:=Worksheets(Worksheets.Count)
a

ワークシートの削除 

'「abc」シートを削除
  Application.DisplayAlerts = False
  Worksheets("abc").Delete
  Application.DisplayAlerts = True
a

ワークシートのコピー 

  'Sheet1シートの前に「data」シートをコピー
  Worksheets("data").Copy Before:=Worksheets("Sheet1")

a

ワークシート追加 

  'アクティブシートの一つ前にシートを追加
  Worksheets.Add

  '先頭に追加
  Worksheets.Add Before:=Sheets(1)

  '末尾に追加
  Worksheets.Add After:=Sheets(Worksheets.Count)

a

シート操作の「並べ替え」 

’並べ替え 
Range("セル範囲").Sort _
　　　　Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes

Range.Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3)

Key1:最初の並べ替えフィールドを範囲名 (文字列) またはRangeオブジェクトで指定
Order1:xlAscending (昇順・既定値) / xlDescending (降順)
Header:xlNo (見出しなし・既定値) / xlYes (見出しあり)

前の設定（ワークシートで手作業でやった並べ替えのオプションも含む）が引き継がれるオプション
MatchCase/Orientation/SortMethodなど

a

重複データの削除 

' 重複データの削除 指定列 1列名
  Range("セル範囲").RemoveDuplicates Columns:=1, Header:=xlNo
  
' 重複データの削除 指定列 複数
  Range("セル範囲").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

Columns:重複をチェックする列の指定
Array 関数を使用して複数の列を指定(組み合わせで重複をチェック)

重複の判定は指定した列での完全一致

Header:ヘッダーがある場合、xlYes、ヘッダーがない場合、xlNoを指定

a

最後の「_」より後の文字を取り出す 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ 最後の「_」より後の文字を取り出す
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfSliceRearStrRevUs(ByVal tStr As String) As String
    zfSliceRearStrRevUs = Mid(tStr, InStrRev(tStr, "_") + 1)
End Function
a

最初の「_」より後ろの文字列を取り出す 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ 最初の「_」より後ろの文字列を取り出す
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfSliceRearStrUs(ByVal tStr As String) As String
    zfSliceRearStrUs = Mid(tStr, InStr(tStr, "_") + 1)
End Function

a

ファイルパス・ファイル名から拡張子のみを取り出す 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ ファイルパス・ファイル名から拡張子のみを取り出す
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfSliceFileNameExt(ByVal fName As String) As String
    zfSliceFileNameExt = Mid(fName, InStrRev(fName, ".") + 1)
End Function

a

ファイル名から拡張子なしのファイル名の取り出す 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ ファイル名から拡張子なしのファイル名の取り出す
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfSliceFileNameNoExt(ByVal fName As String) As String
    Dim extName As String
    extName = Mid(fName, InStrRev(fName, "."))
    zfSliceFileNameNoExt = Replace(fName, extName, "")
End Function
a

ファイルパスからファイル名(拡張子あり)を取り出す 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ ファイルパスからファイル名(拡張子あり)を取り出す
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfSliceFileName(ByVal filePath As String) As String
    zfSliceFileName = Mid(filePath, InStrRev(filePath, "\") + 1)
End Function

a

全角半角のスペースを取り除く 

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
'★ 全角半角のスペースを取り除く
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Function zfDeleteSpace(ByVal tStr As String) As String
    Dim resStr As String
    resStr = Replace(tStr, " ", "")
    resStr = Replace(resStr, "　", "")
    zfDeleteSpace = resStr
End Function

a

イベント発生の抑制 

'新たなイベント発生の抑制------
Application.EnableEvents = False

'元に戻す------
Application.EnableEvents = True
a

計算方法の設定 

'手動計算
Application.Calculation = xlCalculationManual

'再計算の実行
Application.Calculate 

'自動計算
Application.Calculation = xlCalculationAutomatic
a

処理時間の計測 

'計測開始
    Dim myspeed As Double
    Dim starttime As Double
    starttime = Timer
'---------------------------

'計測終了
   myspeed = Timer - starttime
   Debug.Print "処理時間：" & myspeed & "秒"
'---------------------------

a

ファイルオブジェクト生成 

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
a

ブックを閉じる 

'上書き保存
Workbooks("Dummy.xlsx").Close SaveChanges:=True

'保存せずに保存
Workbooks("Dummy.xlsx").Close SaveChanges:=False
a

ブックを開く 

'指定したブックを開く(ドライブ名・・・拡張子)
Workbooks.Open Filename:="C:\・・・\test.xlsx"

'指定したブックを開き、オブジェクト指定
Dim wb as As Workbook
Set wb1 = Workbooks.Open(Filename:="C:\・・・\test.xlsx")

a

データの最終行と列を取得 

'最終行を取得する(A列を基準)
dim cnt as long
cnt = Cells(Rows.Count, 1).End(xlUp).Row
又は
cnt = Cells(Rows.Count, "A").End(xlUp).Row

’最終列を取得する(１行目を基準)
cnt=cells(1,Columns.Count).End(xlToLeft).Column

a

警告メッセージの停止 

'警告メッセージの停止
Application.DisplayAlerts = False

'警告メッセージを通常表示
Application.DisplayAlerts = True
a

処理を待たせる 

'1秒間処理を中断する
Application.Wait Now + TimeValue("00:00:1")
a

画面描画の停止 

Application.ScreenUpdating = False
Application.ScreenUpdating = True