ExcelVBAサンプルマクロ

保存確認メッセージを自作する

VBAでSaveAsメソッドを実行した時、すでに同じ名前のファイルがあると
自動的にダイアログが表示されますが、「いいえ」や「キャンセル」を押すと「実行時エラー'1004': 'SaveAs'メソッドは失敗しました」が出てしまいます。

このため、エラーを出さずにきちんと処理したい場合は処理を自分で組む必要があります。
まずはサンプルコードから。

サンプルコード



Sub 保存確認メッセージ()

Dim strFilePath As String
Dim strFileName As String
Dim flg As Boolean

'◆保存するパスの設定
strFilePath = ThisWorkbook.Path & "¥"

Do Until flg = True
  '◆保存するファイル名の入力
  strFileName = InputBox("ファイル名を入力してください。(拡張子不要)")

  If strFileName = "" Then
    MsgBox "保存をキャンセルします。"
    Exit Sub
  End If

  '◆拡張子がなければつける
  If Right$(strFileName, 4) <> ".xls" Then
    strFileName = strFileName & ".xls"
  End If

  '◆ファイルに使えない文字が入っているかチェック
  If strFileName Like "*[¥,/,"""",:,<,>,?,*,|]*" Then
    MsgBox "ファイル名に使えない記号が含まれています。"
  Else
    '◆開いているかチェック
    If fncBookOpen(strFileName) = False Then
      '◆入力したファイル名が保存先にあるかチェック
      If Dir(strFilePath & strFileName) = "" Then
        flg = True
      Else
        If MsgBox(strFileName & "はすでに存在します。上書きしますか?", vbYesNo + vbDefaultButton2) = vbYes Then
          Application.DisplayAlerts = False
          flg = True
        End If
      End If
    End If
  End If
Loop

ThisWorkbook.SaveAs strFilePath & strFileName

End Sub


Public Function fncBookOpen(strFileName As String) As Boolean

'◆ファイルが開いているかチェック
'  (開いている→True、開いていない→False)

On Error GoTo NotOpen

Workbooks(strFileName).Activate

'◆開いている場合
If ThisWorkbook.Name <> strFileName Then
  If MsgBox("すでに同じ名前のファイルが開いています。開いているファイルを閉じて、" & vbCrLf & _
    "このファイルを「 " & strFileName & "」という名前で保存しますか?", vbYesNo) = vbYes Then
      Workbooks(strFileName).Close
  Else
    fncBookOpen = True
  End If
End If

NotOpen:  '◆開いていない場合
ThisWorkbook.Activate

End Function

まじめに処理しようと思うとコードが長くなりますが、
「IFステートメント」「Do...Loopステートメント」などの基本的なものしか使っていません。

条件分岐がややこしい場合は、フローチャートで考えてみるとわかりやすくなります。
ファイル保存のフローチャート

ファイル名を入力させるテキストボックスはInputBox関数で表示します。
キャンセルをした場合は""が返るので、""の場合はExit Subでプロシージャを抜けます。

次に、入力されたファイル名に拡張子をつけます。
InputBoxのメッセージには「(拡張子不要)」と表示するのですが、そう書いてあっても
拡張子まで含めて入力してしまう人が1人2人は出ることを考えて、「拡張子がなかったらつける」という形にしています。

その後はファイル名に使えない文字が入っていないか、同名のブックを開いていないか、保存先フォルダに同名のファイルがないかを
順にチェックしていきます。

長くなりそうだったので、ファイルが開いているかのチェックは
別にユーザー定義関数「fncBookOpen」を作り、本体から分けました。

チェックがOKだったら変数flgをTrueにします。
するとDo...Loopステートメントの終了条件を満たすので、繰り返し処理を抜けてファイル保存をします。


ファイルが開いているかどうかをチェックするユーザー定義関数「fncBookOpen」はまず、エラーが出た場合ラベル「NotOpen」へ
飛ぶようにOn Resume GoToステートメントを記述しておきます。

引数で指定したブックをアクティブにし、開いていなければエラーが発生します(NotOpenへ飛ぶ)

エラーが発生した場合は保存もとのブックをアクティブにして終わります。
ユーザー定義関数「fncBookOpen」の戻り値はBoolean型で、
Boolean型の初期値はFalseなのでエラーが出た場合(ブックを開いてない場合)はFalseが返ります。


エラー処理をせずにFor Each...Nextステートメントでループさせて
判定してもいいのですが、For Each...Nextステートメントで処理する場合は、
strConv関数で大文字・小文字を揃えてからファイル名を判定する必要があって面倒なので、こっちの方法を採用しました。


ただ、見てのとおり真面目に保存するファイル名を判定しようとすると
かなり面倒くさいです。
これくらい書くくらいだったら、普通にSaveAsメソッドで1行書いてしまって
操作する人がキャンセルしないように気をつける、間違えたら一度終了させて再度実行する、といった運用を徹底した方が
すっきりする・・・・・・かもしれません。

ExcelVBAサンプルマクロ

重複しないファイル名をつける

重複しないファイル名をつけて保存するマクロのサンプルコードです。

サンプルコード



Sub 重複しないファイル名をつける()

Dim strFilePath As String
Dim strFileName As String

strFilePath = ThisWorkbook.Path & "¥"
strFileName = "Book1"

Do Until Dir(strFilePath & strFileName & ".xls") = ""
  strFileName = strFileName & "_"
Loop

ThisWorkbook.SaveAs strFilePath & strFileName & ".xls"

End Sub


サンプルコード解説


Dir関数は引数で指定したファイルがあればファイル名、なければ""を返します。

あらかじめ、変数strFileNameに保存するファイル名(サンプルではBook1)を
セットしておき、Dir関数で判定。

もし同じ名前のファイルがあれば、「_」をつけるという処理を、
一致するファイル名がなくなるまで繰り返します。

最後に拡張子をつけて保存すれば完成。

サンプルコードではThisWorkbookとしていますが、
記述を変えればもちろん、他のブックでも保存可能です。


ExcelVBAサンプルマクロ

USBのパスを取得する

USBメモリのパスを取得するマクロのサンプルコードです。

サンプルコード



Sub USBチェック()

Dim FSO As Object
Dim obj As Object
Dim strDrivePath As String

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each obj In FSO.Drives
  If obj.DriveType = 1 Then      '◆リムーバブルディスクの場合
    If obj.DriveLetter <> "A" Then '◆フロッピーの場合はとばす
      strDrivePath = obj.DriveLetter & ":¥"
    End If
  End If
Next

If strDrivePath <> "" Then
  MsgBox "USBドライブのパスは" & strDrivePath
Else
  MsgBox "USBメモリがありません。"
End If

Set FSO = Nothing

End Sub


FileSystemObjectのDriveTypeプロパティを調べることで、
ドライブの種類が判別できます。




種類
0 不明
1 リムーバブルディスク
2 ハードディスク
3 ネットワークドライブ
4 CD-ROMドライブ
5 RAMディスク


リムーバブルディスクでなおかつAドライブ(フロッピーディスク)ではない
パスを取得することで、USBドライブのパスを取得します。

ExcelVBAサンプルマクロ

デスクトップなどの特殊フォルダ名を取得する

デスクトップのパス名を取得したい場合、ユーザー名が入るため、
普通のやり方では取得できません。

特殊なパスを取得するには、VBAだけではできないので
WSH(Windows Script Host)というのを使います。

WSHとは、ものすごく大雑把に言ってしまうとテキストファイルに
VBAっぽいコードを書いて簡単なプログラムを実行しちゃおう、
というWindowsについている機能。

Windowsを操作するためのオブジェクトもセットになっているので、
WSHのオブジェクトを通すことで特殊フォルダのパスが取得できます。

コードはいたってシンプル。

サンプルコード



Sub 特殊フォルダ名を取得()

Dim strFileName As String

strFileName = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "¥"
MsgBox strFileName

End Sub

特殊フォルダのパスはWSHのWscript.ShellオブジェクトにあるSpecialFoldersプロパティに格納されています。
インデックス番号でも指定できます。



インデックスパス
1C:¥Documents and Settings¥All Users¥デスクトップ
2C:¥Documents and Settings¥All Users¥スタート メニュー
3C:¥Documents and Settings¥All Users¥スタート メニュー¥プログラム
4C:¥Documents and Settings¥All Users¥スタート メニュー¥プログラム¥スタートアップ
5C:¥Documents and Settings¥<ユーザー名>¥デスクトップ
6C:¥Documents and Settings¥<ユーザー名>¥Application Data
7C:¥Documents and Settings¥<ユーザー名>¥PrintHood
8C:¥Documents and Settings¥<ユーザー名>¥Templates
9C:¥WINDOWS¥Fonts
10C:¥Documents and Settings¥<ユーザー名>¥NetHood
11C:¥Documents and Settings¥<ユーザー名>¥デスクトップ
12C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー
13C:¥Documents and Settings¥<ユーザー名>¥SendTo
14C:¥Documents and Settings¥<ユーザー名>¥Recent
15C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー¥プログラム¥スタートアップ
16C:¥Documents and Settings¥<ユーザー名>¥Favorites
17C:¥Documents and Settings¥<ユーザー名>¥My Documents
18C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー¥プログラム



ExcelVBAサンプルマクロ

フォルダを選択させるダイアログを表示させる

ファイルではなく、フォルダを選択させたい時はFileDialogオブジェクトを
使います。

FileDialogオブジェクトに「msoFileDialogFolderPicker」を指定すると、
フォルダを選択させるダイアログが表示されます。

サンプルコード

]

Sub フォルダ選択()

Dim strFolderName As String

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = ThisWorkbook.Path & "¥"
  .Show
 
  If .SelectedItems.Count = 0 Then
    MsgBox "キャンセルします。"
    Exit Sub
  End If
 
  strFolderName = .SelectedItems(1)
 
End With

End Sub


ただし、この方法は2002以降だけで有効です。
2000以前のものでフォルダを選択させるダイアログを表示させるには、
WindowsAPIを使わないといけません。



ExcelVBAサンプルマクロ

フルパスをパスとファイル名に分ける

GetOpenFilenameメソッドなどでファイルを選ばせる場合、
取得できるのはファイルのフルパスになります。

ブックを操作する場合はファイル名で指定する必要があるので、
フルパスを取得した後パスとファイル名に分けておくと扱いやすいです。

サンプルコード



Sub フルパス分割()

Dim strFullPath As String
Dim strPath As String
Dim strName As String

strFullPath = Application.GetOpenFilename

If strFullPath = "False" Then
  MsgBox "キャンセル"
  Exit Sub
End If

'◆フルパスをパスとファイル名に分割
strName = Dir(strFullPath)
strPath = Replace(strFullPath, strName, "")

End Sub


Dir関数は引数で指定したファイルがあればそのファイル名を返します。
引数にフルパスを指定すれば、そのファイルのファイル名だけ抜き出せます。

ファイル名が取得できたら、あとはフルパスからファイル名部分を
""で置換するだけでパスも取得できます。


ExcelVBAサンプルマクロ

ファイルを開くダイアログではじめに開くフォルダを設定する

GetOpenFilenameメソッドではオプションで設定されている
カレントフォルダが最初に開くようになっています。

GetOpenFilenameメソッドだけでは最初に開くフォルダを指定できないので、
入門書ではよく、カレントディレクトリを変更するChDirステートメントと
併用する方法が書かれています。

サンプルコード1



Sub ファイル選択1()

Dim strFileName As String

ChDir ThisWorkBook.Path & "¥"
strFileName = Application.GetOpenFilename

End Sub


しかし、このままではマクロを終了した後もカレントディレクトリが
マクロで指定したフォルダのままになってしまいます。

オプションは個人個人が自分のやりやすいように設定するもの。
それを勝手にいじってそのままにするのは反対です。


そこで、ChDirステートメントを使う前にCurDirステートメントで
変更前のカレントフォルダを取得し、処理実行後に元の設定に戻すか、
規定のフォルダを指定してダイアログを開ける
FileDialogオブジェクトを使うのがいいでしょう。

サンプルコード2



Sub ファイル選択2()

Dim strCurFolder As String '元のカレントフォルダのパス
Dim strFileName As String '選択したファイル名
Dim strFilePath As String 'ダイアログ表示時のカレントフォルダ

'◆初期設定
strCurFolder = CurDir
strFilePath = ThisWorkbook.Path & "¥"

'◆ファイルを開くダイアログ表示
ChDir strFilePath
strFileName = Application.GetOpenFilename(MultiSelect:=False)

If strFileName <> "False" Then
  MsgBox "選択したファイル名は" & strFileName & "です。"
Else
  MsgBox "キャンセルされました。"
End If

'◆カレントフォルダを元に戻す
ChDir strCurFolder

End Sub


ただし、CurDirステートメントはドライブが違うと変更できません。

たとえば、デスクトップ(Cドライブ)がカレントディレクトリの時に
他のドライブや、サーバーのフォルダを指定しても、カレントディレクトリは変わりません。

ローカルドライブならChDriveステートメントで変更できますが、
サーバーの場合、ChDriveステートメントで指定するとエラーが発生します。


最初に開くフォルダにサーバーを指定したい場合は、
FileDialogオブジェクトを使うといいでしょう。

ただし、FileDialogオブジェクトは2002以降でないと動きません。

サンプルコード3



Sub ファイル選択3()

Dim strFilePath As String
Dim strFileName As String

strFilePath = ThisWorkbook.Path & "¥"

With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = strFilePath
  .Show

  If .SelectedItems.Count = 0 Then
    MsgBox "キャンセルされました。"
    Exit Sub
  End If

  strFilePath = .SelectedItems(1)

End With

End Sub


InitialFileNameプロパティに規定のフォルダのパスを設定し、
Showメソッドでダイアログを開きます。
他にも、MultiSelectプロパティを指定すれば複数選択なども可能になっています。

SelectedItemsのCountプロパティから、選択したファイルの数がわかるので、
0の時は処理を終了させます。

ExcelVBAサンプルマクロ

ファイルを選択させるダイアログを表示する

ファイルを選択させるダイアログを表示するには、
GetOpenFileNameメソッドまたはGetSaveAsFilenameメソッドを使います。

サンプルコード1



Sub ファイル選択1()

Dim strFileName As String

strFileName = Application.GetOpenFilename
strFileName = Application.GetSaveAsFilename

End Sub


どちらもよく似ていますが、以下のような違いがあります。
・ボタンの名称、タイトルバーの文字が違う。
・GetOpenFileNameメソッドは引数MultiSelectにTrueを指定することで
 複数選択可能だが、GetSaveAsFilenameメソッドは単数のみ。
・GetSaveAsFilenameメソッドは規定のフォルダを指定できるが、
 GetOpenFileNameメソッドは指定できない。
・GetSaveAsFilenameメソッドはファイルを選ぶまで決定ボタン
 (保存)が押せない。

なお、GetOpenFileNameメソッド、GetSaveAsFilenameメソッドは
選択したファイル名を取得するだけで、実際の開く処理・
保存する処理は行われないため、別にOpenメソッドやSaveAsメソッドを実行する必要があります。


GetOpenFileNameメソッドは第1引数を指定する事で、
特定の拡張子のファイルのみ表示させることが出来ます。

サンプルコード2



Sub ファイル選択2()

Dim strFileName As String
strFileName = Application.GetOpenFilename("Excelファイルとテキストファイル,*.xls;*.txt")

End Sub


第1引数は「ファイルの種類に表示させる文字,拡張子」を文字列で指定します。
複数の拡張子を表示させたい場合は「;」で区切ります。


GetSaveAsFilenameメソッドは第1引数を指定する事で、
ダイアログを開いた時に最初に表示されるフォルダを指定することができます。

サンプルコード3



Sub ファイル選択3()

Dim strFileName As String
strFileName = Application.GetSaveAsFilename(ThisWorkbook.Path & "¥")

End Sub


GetOpenFileNameメソッドには規定のフォルダを指定する引数がないため、
最初に開くフォルダを指定する事ができません。
ファイルを開くダイアログを表示させつつ、規定のフォルダを指定したい場合は
ChDirステートメントなどを使います。


ExcelVBAサンプルマクロ

最新のファイルを開く

FileDateTime関数を使うと、ファイルの更新日付が取得できます。
この関数を使って、同一フォルダ内にある最新ファイルを開く
サンプルです。

サンプルコード



Sub 最新ファイルを開く()

Dim strFileName As String
Dim strFilePath As String

strFilePath = ThisWorkbook.Path & "¥"
strFileName = fncGetNewFile(strFilePath)

If strFileName = "" Then
  MsgBox "ファイルがありません。"
  Exit Sub
End If

Workbooks.Open strFilePath & strFileName

End Sub


Public Function fncGetNewFile(strFilePath As String) As String

Dim strFileName As String
Dim tmpFileName As String
Dim time As Date
Dim pretime As Date
 
tmpFileName = Dir(strFilePath & "*.xls")

Do Until tmpFileName = ""
  pretime = FileDateTime(strFilePath & tmpFileName)
  If pretime > time Then
    time = pretime
    strFileName = tmpFileName
  End If
  tmpFileName = Dir()
Loop

fncGetNewFile = strFileName

End Function


処理をすっきりするために、最新日付のファイル名を取得する部分を
ユーザー定義関数にして、ファイルパスの設定やファイルを開く処理とは分けました。

ユーザー定義関数fncGetNewFileで最新ファイル名を取得し、
呼び出し元のマクロで取得したファイル名を開いています。


ExcelVBAサンプルマクロ

フォルダ名を取得する

Dir関数の第2引数を指定すると、ファイル名だけではなく、
フォルダの名前なども取得できるようになります。


定数内容
vbNomal標準ファイルのみを取得対称にする
vbReadOnly読み取り専用ファイルを取得対象に含める
vbHidden隠しファイルを取得対象に含める
vbSystemシステムファイルを取得対象に含める(Winのみ)
vbVolumeボリュームラベル。すべての属性は無効。
vbDirectoryフォルダを取得対象に含める
vbAliasエイリアスファイルを取得対象に含める(Macのみ)


サンプルコード



Sub フォルダにあるフォルダ名をすべて取得()

Dim strFilePath As String
Dim strFileName As String

strFilePath = ThisWorkbook.Path & "¥"
strFileName = Dir(strFilePath, vbDirectory)

Do Until strFileName = ""
  If GetAttr(strFilePath & strFileName) = vbDirectory Then
    If strFileName <> "." And strFileName <> ".." Then
      MsgBox strFileName
    End If
  End If
  strFileName = Dir()
Loop

End Sub


引数にvbDirectoryを取得した場合は、フォルダのみを取得対象に
するのではなく、「通常のファイルとフォルダの名前を取得」という
動作になります。

そのため、フォルダ名だけを取得したい場合は、GetAttr関数で
フォルダかどうかを判定する必要があります。

◆GetAttr関数
GetAttr(パス)

また、現在のフォルダが「.」、親フォルダが「..」という名前で
取得されてしまうので、Ifステートメントで条件分岐し、
表示させないようにしています。

<<前の10件  1 2 3 4 5..  次の10件>>


Powered by Seesaa
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。