basファイルの上書きを実現したい。

basファイルの上書き。

Xxxx(職員名).xlsmファイルを開いたときに、指定のフォルダ内に、更新日時の新しい“yyyy.bas”と“zzz.bas”があれば、古いbasファイルを新しいbasファイルに書き換えたい。

前任者の残したコード
エラーは出ませんが、正しくも動いていない。
標準モジュールに書いてあります。

Sub UpdateBasFile()
Dim FolderPath As String
Dim BasFileName As String
Dim BasFile As String
Dim NewestFile As String
Dim NewestDate As Date
Dim FileDate As Date

' フォルダのパスを設定
FolderPath = "指定したパス"

' BASファイル名を設定
BasFileName = "yyyy.bas"

' 指定されたフォルダ内のすべてのBASファイルをチェック
BasFile = Dir(FolderPath & "\" & BasFileName)
Do While BasFile <> ""
    FileDate = FileDateTime(FolderPath & "\" & BasFile)
    If FileDate > NewestDate Then
        NewestDate = FileDate
        NewestFile = BasFile
    End If
    BasFile = Dir
Loop

If NewestFile <> "" Then
    Dim ThisWorkbookPath As String
    ThisWorkbookPath = ThisWorkbook.Path
    FileCopy FolderPath & "\" & NewestFile, ThisWorkbookPath & "\" & BasFileName
End If

End Sub

8524ba23

2024/04/30 02:52

https://teratail.com/help/question-tips#questionTips11 https://teratail.com/help/question-tips は読みましたか？読んだ結果を本文に反映ください。解決のヒントを探れるかもしれません。

mdj

2024/04/30 04:31

yyyy.basを1個いれたら指定フォルダを作成して、1行ずつデバッグして引数を確認したらわかるかなと思います。

行動規範の内容に同意します

回答1件

vba
1' フォルダのパスを設定
2FolderPath = "指定したパス"
3引用テキスト
4' BASファイル名を設定
5BasFileName = "yyyy.bas"

vba
1ThisWorkbookPath = ThisWorkbook.Path

指定したフォルダ（以下「Aフォルダ」）内に "yyyy.bas" という名前の bas ファイルが存在する。
そのマクロを実行するマクロ有効ブックが保存されているフォルダ（以下「Bフォルダ」）内に同名の bas ファイルが存在していなければ、Aフォルダ内の bas ファイルをBフォルダにコピーし、処理を終了する。
Bフォルダ内に同名の bas ファイルが存在している場合は、Aフォルダ内の bas ファイルの更新日時とBフォルダ内の bas ファイルの更新日時を比較し、もし前者の更新日時の方が新しい場合は、Aフォルダ内の bas ファイルでBフォルダ内の bas ファイルを上書きコピーする。

とりあえず以上のような前提である場合。

vba
1Sub UpdateBasFile()
2
3    Dim BasFileName As String
4    Dim TargetFolderPath As String
5
6    'bas ファイルの名前
7    BasFileName = "yyyy.bas"
8
9    '指定フォルダのパス
10    TargetFolderPath = "指定したフォルダパス"
11
12    '指定フォルダ内に同名の bas ファイルが存在しない場合
13    If Dir(TargetFolderPath & "\" & BasFileName) = "" Then
14        Debug.Print "フォルダ " & TargetFolderPath & " にファイル " & BasFileName & "は存在しません。"
15        'プロシージャを抜ける
16        Exit Sub
17    End If
18
19    Dim CurrentFolderPath As String
20
21    'このブックが保存されているフォルダのパスを取得
22    CurrentFolderPath = ThisWorkbook.Path
23
24    'そのフォルダ内に同名の bas ファイルが存在しない場合
25    If Dir(CurrentFolderPath & "\" & BasFileName) = "" Then
26        Debug.Print "フォルダ " & CurrentFolderPath & " にファイル " & BasFileName & "は存在しません。"
27        'bas ファイルをコピーする
28        FileCopy TargetFolderPath & "\" & BasFileName, _
29                 CurrentFolderPath & "\" & BasFileName
30        Debug.Print "フォルダ " & CurrentFolderPath & " にファイル " & BasFileName & "をコピーしました。"
31        'プロシージャを抜ける
32        Exit Sub
33    End If
34    
35    Dim TargetFileModifyDateTime As Date
36    Dim CurrentFileModifyDateTime As Date
37    
38    '指定フォルダ内の bas ファイルの更新日時を取得
39    TargetFileModifyDateTime = FileDateTime(TargetFolderPath & "\" & BasFileName)
40    Debug.Print "TargetFileModifyDateTime: " & TargetFileModifyDateTime
41    
42    'このブックが保存されているフォルダ内の同名の bas ファイルの更新日時を取得
43    CurrentFileModifyDateTime = FileDateTime(CurrentFolderPath & "\" & BasFileName)
44    Debug.Print "CurrentFileModifyDateTime: " & CurrentFileModifyDateTime
45    
46    '前者の bas ファイルの更新日時が、後者の bas ファイルの更新日時よりも新しい場合
47    If TargetFileModifyDateTime > CurrentFileModifyDateTime Then
48        'bas ファイルを上書きコピーする
49        FileCopy TargetFolderPath & "\" & BasFileName, _
50                 CurrentFolderPath & "\" & BasFileName
51        Debug.Print "フォルダ " & CurrentFolderPath & " にファイル " & BasFileName & "をコピーしました。"
52    End If
53
54End Sub