-ChatGPT4-に質問　ＶＢＡでパスワード付きのファイルを解除してコピーしてファイル名を変更して加工用のファイルを作成しシートも追加する

2023.04.14

-ChatGPT4-

-ChatGPT4-に質問

ＶＢＡでパスワード付きのファイルを解除してコピーしてファイル名を変更して加工用のファイルを作成しこのブックにある給与仕訳テンプレートシートと給与仕訳シートを追加するようにしてください。パスワードは解除してください。

ChatGPT4の回答

Option Explicit

Sub CopyFileWithNewName()

    Dim SourceFile As Variant
    Dim TargetFolder As Variant
    Dim CompanyName As String
    Dim MonthStr As String
    Dim NewFileName As String
    Dim FileExtension As String
    Dim fso As Object
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim Password As String
    Dim wsTemplate As Worksheet
    Dim wsJournal As Worksheet

    ' パスワードを指定
    Password = "your_password_here"

    ' 現在のワークブックをソースブックとして設定
    Set wbSource = ThisWorkbook

    ' 給与仕訳テンプレートシートと給与仕訳シートを取得
    On Error Resume Next
    Set wsTemplate = wbSource.Worksheets("給与仕訳テンプレート")
    Set wsJournal = wbSource.Worksheets("給与仕訳")
    On Error GoTo 0

    If wsTemplate Is Nothing Or wsJournal Is Nothing Then
        MsgBox "シートが見つかりません。シート名を確認してください。"
        Exit Sub
    End If

    ' ファイル選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "コピー先のファイルを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            SourceFile = .SelectedItems(1)
        Else
            MsgBox "ファイルが選択されませんでした。処理を終了します。"
            Exit Sub
        End If
    End With

    ' パスワード付きのファイルを開く
    On Error Resume Next
    Set wbTarget = Workbooks.Open(SourceFile, Password:=Password)
    On Error GoTo 0
    If wbTarget Is Nothing Then
        MsgBox "パスワードが違います。処理を終了します。"
        Exit Sub
    End If

    ' シートをコピーして、ターゲットファイルに追加
    wsTemplate.Copy After:=wbTarget.Worksheets(wbTarget.Worksheets.Count)
    wsJournal.Copy After:=wbTarget.Worksheets(wbTarget.Worksheets.Count)

    ' パスワードを解除
    wbTarget.Unprotect Password

    ' 会社名と月を入力
    CompanyName = InputBox("会社名を入力してください。", "会社名の入力")
    If CompanyName = "" Then
        MsgBox "会社名が入力されませんでした。処理を終了します。"
        Exit Sub
    End If

        MonthStr = InputBox("月を入力してください。（例: 1月の場合は '1'、10月の場合は '10'）", "月の入力")
    If MonthStr = "" Then
        MsgBox "月が入力されませんでした。処理を終了します。"
        Exit Sub
    End If

    ' 新しいファイル名を作成
    FileExtension = Mid(SourceFile, InStrRev(SourceFile, "."))
    NewFileName = CompanyName & "_給与データ_" & MonthStr & "月度" & FileExtension

    ' フォルダ選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "ファイルを保存するフォルダを選択してください"
        If .Show = -1 Then
            TargetFolder = .SelectedItems(1)
        Else
            MsgBox "フォルダが選択されませんでした。処理を終了します。"
            Exit Sub
        End If
    End With

    ' ターゲットファイルを新しいファイル名で保存
    wbTarget.SaveAs TargetFolder & Application.PathSeparator & NewFileName

    ' ターゲットファイルを閉じる
    wbTarget.Close SaveChanges:=False

    ' 確認メッセージを表示
    MsgBox "シートが正常にコピーされ、選択されたファイルに追加されました。" & vbCrLf & "新しいファイル名: " & NewFileName, vbInformation, "完了"

End Sub
タイトルとURLをコピーしました