'========================================================================================= ' 002　ファイル名を変更する・ファイルを移動する '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードを含んでいます。（概ね下半分） ' ★★★の行またはサブプロシージャーが、タイトル機能に関係するコードです。（概ね上半分） ' UserForm1と2にもコードがありますが、おためし機能の動作用のコードです。 '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- Option Explicit Dim ドライブ As String '★★★ Dim 旧フォルダ名 As String '★★★ Dim 新フォルダ名 As String '★★★ Dim 旧ファイル名 As String '★★★ Public 新ファイル名 As String '★★★ UserForm1でも使うので Publicにした Dim 旧フルパス As String '★★★ Dim 新フルパス As String '★★★ Dim 現在の名前 As String '★★★ Dim 新しい名前 As String '★★★ Public タイトル As String Public スタイル As Long Public メッセージ As String Public 応答 As Variant '========================================================================================= Private Sub ファイル名を変更する() '★★★ Name 現在の名前 As 新しい名前 End Sub '----------------------------------------------------------------------------------------- Private Sub ファイルを移動する() '★★★ 旧パス = ドライブ & 旧フォルダ & 旧ファイル名 新パス = ドライブ & 新フォルダ & 旧ファイル名 Name 旧パス As 新パス End Sub '----------------------------------------------------------------------------------------- Private Sub ファイルの移動と名前の変更を行う() '★★★ 現在の名前 = ドライブ & 旧フォルダ & 旧ファイル名 新しい名前 = ドライブ & 新フォルダ & 新ファイル名 Name 現在の名前 As 新しい名前 End Sub '----------------------------------------------------------------------------------------- Private Sub ファイル名を変更して移動する() '★★★ 旧パス = ドライブ & 旧フォルダ & 旧ファイル名 新パス = ドライブ & 新フォルダ & 新ファイル名 Name 旧パス As 新パス End Sub '----------------------------------------------------------------------------------------- Private Sub 環境設定する() '★★★ ドライブ = Worksheets("Title").Range("E11").Value 'ドライブ番号を取得する 旧フォルダ名 = Worksheets("Title").Range("E12").Value 'フォルダ名を　　〃 旧ファイル名 = Worksheets("Title").Range("E13").Value '旧ファイル名を　〃 新ファイル名 = Worksheets("Title").Range("E14").Value '新　　〃　　　　〃 ChDrive ドライブ 'カレントドライブを変更する ChDir ドライブ & ":\" & 旧フォルダ名 'カレントフォルダを　〃 旧フルパス = ドライブ & ":\" & 旧フォルダ名 & _ "\" & 旧ファイル名 & ".xls" '旧ファイルのフルパスを組んでおく 新フルパス = ドライブ & ":\" & 旧フォルダ名 & _ "\" & 新ファイル名 & ".xls" '新ファイルのフルパスを組んでおく End Sub '========================================================================================= '----------------------------------------------------------------------------------------- Sub おためしマクロ() Worksheets("Title").Select Range("O17").Select 'カーソルを定位置へ移動する 環境設定する 'おためしメッセージ表示・テストデータ作成用 おためしメッセージを表示する If 応答 = vbYes Then テストデータを作成する Range("A2").Select UserForm1.Show End If End Sub '----------------------------------------------------------------------------------------- Private Sub おためしメッセージを表示する() タイトル = "500連発 第2弾 サンプルマクロ" スタイル = 32 + 4 'vbQuestion + vbYesNo メッセージ = "テスト用の少量データを " & ドライブ & "ドライブの、" & 旧フォルダ名 & "フォルダへ、" & Chr(13) & Chr(13) & _ "「" & 旧ファイル名 & ".xls」 と 「" & 新ファイル名 & ".xls」 として書き込みます。" & Chr(13) & Chr(13) & _ "よろしいですか （終了後は削除されます）" 応答 = MsgBox(メッセージ, スタイル, タイトル) End Sub '----------------------------------------------------------------------------------------- Private Sub テストデータを作成する() Sheets("テストデータ").Select Sheets("テストデータ").Copy '新しいブックにコピーする Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=旧ファイル名 & ".xls" ActiveWorkbook.Close End Sub '----------------------------------------------------------------------------------------- Public Sub テストデータのファイル名を変更する() 'ユーザーフォームから実行されるため Public Subにしている On Error Resume Next Kill 新しい名前 '同名ファイルがあれば削除しておく 現在の名前 = 旧ファイル名 & ".xls" '★★★ 新しい名前 = 新ファイル名 & ".xls" '★★★ ファイル名を変更する '★★★ UserForm2.Show End Sub '----------------------------------------------------------------------------------------- Public Sub テストデータを削除する() Kill 新しい名前 'テスト用ファイルを削除する Worksheets("Title").Select Range("O17").Select 'カーソルを定位置へ移動する メッセージ = "削除しました。" & Chr(13) & Chr(13) & _ "「ファイルを移動する」 のお試し機能はありませんが、" & Chr(13) & _ "標準モジュールに、サンプルマクロがあります" スタイル = 64 'vbInformation 応答 = MsgBox(メッセージ, スタイル, タイトル) End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ◆UserForm1のコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Private Sub CommandButton1_Click() Unload Me Range("A3").Select メッセージ = "ファイル名を 「" & 新ファイル名 & ".xls」 に変更します" スタイル = 64 'vbInformation 応答 = MsgBox(メッセージ, スタイル, タイトル) テストデータのファイル名を変更する '標準モジュールのマクロを実行する End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ◆UserForm2のコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Private Sub CommandButton1_Click() Unload Me Range("A4").Select メッセージ = "「" & 新ファイル名 & ".xls」 を削除します" スタイル = 64 'vbInformation 応答 = MsgBox(メッセージ, スタイル, タイトル) Application.Run macro:="テストデータを削除する" '標準モジュールのマクロを実行する End Sub '-----------------------------------------------------------------------------------------