SPO Excelコピー用VBA

Sub CopyAndUpdateExcelFileInSPO()
    ' SharePoint Online上のExcelファイルをコピーし、データを最新化するVBAコード
    
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceFilePath As String
    Dim targetFolderPath As String
    Dim targetFilePath As String
    Dim originalFileName As String
    Dim fileExtension As String
    Dim newFileName As String
    Dim todayDate As String
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim i As Integer
    
    ' エラーハンドリング
    On Error GoTo ErrorHandler
    
    ' 今日の日付を取得（YYYYMMDD形式）
    todayDate = Format(Date, "yyyymmdd")
    
    ' メインシートのI2、I3セルからパス情報を取得
    Dim mainSheet As Worksheet
    
    ' メインシートの取得（より安全な方法）
    On Error Resume Next
    Set mainSheet = ThisWorkbook.ActiveSheet
    If mainSheet Is Nothing Then
        Set mainSheet = ThisWorkbook.Worksheets(1)
    End If
    On Error GoTo ErrorHandler
    
    ' セルの値が正しく取得できるかチェック
    Debug.Print "現在のワークブック: " & ThisWorkbook.Name
    Debug.Print "対象シート: " & mainSheet.Name
    
    ' I2セル：コピー元ファイルパス、I3セル：コピー先フォルダパス
    On Error Resume Next
    sourceFilePath = Trim(CStr(mainSheet.Range("I2").Value))
    targetFolderPath = Trim(CStr(mainSheet.Range("I3").Value))
    On Error GoTo ErrorHandler
    
    ' 値の確認
    Debug.Print "I2セルの値: [" & sourceFilePath & "]"
    Debug.Print "I3セルの値: [" & targetFolderPath & "]"
    
    ' パスが空または無効な場合のエラーチェック
    If sourceFilePath = "" Or sourceFilePath = "False" Then
        MsgBox "I2セルにコピー元ファイルのSharePointパスを入力してください。" & vbCrLf & _
               "例: https://company.sharepoint.com/.../file.xlsx", vbCritical, "エラー"
        Exit Sub
    End If
    
    If targetFolderPath = "" Or targetFolderPath = "False" Then
        MsgBox "I3セルにコピー先フォルダのSharePointパスを入力してください。" & vbCrLf & _
               "例: https://company.sharepoint.com/.../folder/", vbCritical, "エラー"
        Exit Sub
    End If
    
    ' SharePointパスの基本的な形式チェック
    If Not (LCase(Left(sourceFilePath, 8)) = "https://" Or LCase(Left(sourceFilePath, 7)) = "http://") Then
        MsgBox "I2セルのパスは正しいURL形式で入力してください。" & vbCrLf & _
               "現在の値: " & sourceFilePath, vbCritical, "パス形式エラー"
        Exit Sub
    End If
    
    If Not (LCase(Left(targetFolderPath, 8)) = "https://" Or LCase(Left(targetFolderPath, 7)) = "http://") Then
        MsgBox "I3セルのパスは正しいURL形式で入力してください。" & vbCrLf & _
               "現在の値: " & targetFolderPath, vbCritical, "パス形式エラー"
        Exit Sub
    End If
    
    ' コピー先フォルダパスの末尾に"/"がない場合は追加
    If Right(targetFolderPath, 1) <> "/" Then
        targetFolderPath = targetFolderPath & "/"
    End If
    
    Debug.Print "処理用コピー元: " & sourceFilePath
    Debug.Print "処理用コピー先: " & targetFolderPath
    
    ' ファイル名と拡張子を分離
    originalFileName = Mid(sourceFilePath, InStrRev(sourceFilePath, "/") + 1)
    fileExtension = Mid(originalFileName, InStrRev(originalFileName, "."))
    originalFileName = Left(originalFileName, InStrRev(originalFileName, ".") - 1)
    
    ' 新しいファイル名を作成（日付付き）
    newFileName = originalFileName & "_" & todayDate & fileExtension
    targetFilePath = targetFolderPath & newFileName
    
    ' 画面更新を停止してパフォーマンスを向上
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    ' ソースファイルを読み取り専用で開く（SharePointで他のユーザーが使用中の場合に対応）
    Debug.Print "ソースファイルを開いています: " & sourceFilePath
    Set sourceWorkbook = Workbooks.Open(Filename:=sourceFilePath, _
                                       UpdateLinks:=0, _
                                       ReadOnly:=True, _
                                       IgnoreReadOnlyRecommended:=True)
    
    ' 新しい場所にファイルをコピー（読み取り専用ソースから編集可能なコピーを作成）
    Debug.Print "ファイルをコピーしています: " & targetFilePath
    sourceWorkbook.SaveAs Filename:=targetFilePath, _
                          FileFormat:=xlOpenXMLWorkbook, _
                          ReadOnlyRecommended:=False, _
                          CreateBackup:=False
    
    ' コピー後のファイルを参照として保持
    Set targetWorkbook = ActiveWorkbook
    
    ' 元の読み取り専用ファイルを閉じる
    sourceWorkbook.Close SaveChanges:=False
    
    ' コピー先のファイルで本格的なデータ更新処理を実行
    Debug.Print "コピー先ファイルでデータを更新しています..."
    
    ' 全てのワークシートに対してデータ更新処理を実行
    For Each ws In targetWorkbook.Worksheets
        ws.Activate
        
        ' 数式の再計算
        ws.Calculate
        
        ' ピボットテーブルの更新
        For Each pt In ws.PivotTables
            Debug.Print "ピボットテーブルを更新: " & pt.Name
            pt.RefreshTable
        Next pt
        
        ' 外部データ接続の更新
        If ws.QueryTables.Count > 0 Then
            For i = 1 To ws.QueryTables.Count
                Debug.Print "クエリテーブルを更新: " & i
                ws.QueryTables(i).Refresh BackgroundQuery:=False
            Next i
        End If
        
        ' データ接続の更新
        If ws.ListObjects.Count > 0 Then
            For i = 1 To ws.ListObjects.Count
                Debug.Print "テーブルを更新: " & ws.ListObjects(i).Name
                ws.ListObjects(i).QueryTable.Refresh BackgroundQuery:=False
            Next i
        End If
    Next ws
    
    ' ブック全体の再計算
    targetWorkbook.Application.CalculateFullRebuild
    
    ' コピー先のファイルで非表示シートをすべて表示
    Debug.Print "非表示シートを表示しています..."
    For Each ws In targetWorkbook.Worksheets
        If ws.Visible = xlSheetHidden Or ws.Visible = xlSheetVeryHidden Then
            Debug.Print "シートを表示: " & ws.Name
            ws.Visible = xlSheetVisible
        End If
    Next ws
    
    ' コピー先のファイルでも最終確認として再計算
    targetWorkbook.Application.Calculate
    targetWorkbook.Save
    
    ' 設定を元に戻す
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    Debug.Print "処理が完了しました。"
    Debug.Print "コピー先: " & targetFilePath
    MsgBox "ファイルのコピーとデータ更新が完了しました。" & vbCrLf & _
           "コピー先: " & newFileName, vbInformation, "処理完了"
    
    Exit Sub
    
ErrorHandler:
    ' エラー発生時の処理
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 開いているワークブックがある場合は閉じる
    On Error Resume Next
    If Not sourceWorkbook Is Nothing Then
        sourceWorkbook.Close SaveChanges:=False
    End If
    On Error GoTo 0
    
    ' 詳細なエラー情報を表示
    Dim errorMsg As String
    errorMsg = "エラーが発生しました:" & vbCrLf & vbCrLf
    errorMsg = errorMsg & "エラー番号: " & Err.Number & vbCrLf
    errorMsg = errorMsg & "エラー内容: " & Err.Description & vbCrLf & vbCrLf
    
    ' 一般的なエラーの対処法を追加
    Select Case Err.Number
        Case 1004
            errorMsg = errorMsg & "対処法:" & vbCrLf
            errorMsg = errorMsg & "• SharePointへの接続を確認してください" & vbCrLf
            errorMsg = errorMsg & "• ファイルパスが正確か確認してください" & vbCrLf
            errorMsg = errorMsg & "• ファイルの権限を確認してください" & vbCrLf
            errorMsg = errorMsg & "• SharePointにサインインしているか確認してください"
        Case 438
            errorMsg = errorMsg & "対処法:" & vbCrLf
            errorMsg = errorMsg & "• I2、I3セルの値を確認してください" & vbCrLf
            errorMsg = errorMsg & "• セルに正しいSharePointのパスが入力されているか確認してください"
        Case Else
            errorMsg = errorMsg & "対処法:" & vbCrLf
            errorMsg = errorMsg & "• イミディエイトウィンドウでデバッグ情報を確認してください" & vbCrLf
            errorMsg = errorMsg & "• SharePoint接続とファイルパスを再確認してください"
    End Select
    
    Debug.Print "=== エラー詳細 ==="
    Debug.Print "エラー番号: " & Err.Number
    Debug.Print "エラー内容: " & Err.Description
    Debug.Print "発生行: " & Erl
    Debug.Print "=================="
    
    MsgBox errorMsg, vbCritical, "処理エラー"
End Sub

' SharePoint認証が必要な場合の補助関数
Sub AuthenticateSharePoint()
    ' SharePointへの認証処理（必要に応じて実装）
    ' 通常はWindows認証またはOffice 365の認証が自動的に行われます
    
    ' 手動で認証が必要な場合は、以下のような処理を追加
    ' Application.OnTime Now + TimeValue("00:00:01"), "CheckConnection"
End Sub

' 接続確認用の補助関数
Function CheckSharePointConnection(filePath As String) As Boolean
    ' SharePoint接続の確認
    On Error GoTo ConnectionError
    
    Dim testWorkbook As Workbook
    Set testWorkbook = Workbooks.Open(filePath, ReadOnly:=True)
    testWorkbook.Close SaveChanges:=False
    
    CheckSharePointConnection = True
    Exit Function
    
ConnectionError:
    CheckSharePointConnection = False
    Debug.Print "SharePoint接続エラー: " & Err.Description
End Function

' カスタム設定用のサブルーチン（パスを設定する場合）
Sub SetFilePathsAndRun()
    ' 実際の環境に合わせてパスを設定してから実行
    Dim sourcePath As String
    Dim targetPath As String
    
    ' パスの設定例
    sourcePath = InputBox("コピー元ファイルのSharePointパスを入力してください:", _
                         "ソースファイルパス", _
                         "https://yourcompany.sharepoint.com/sites/yoursite/Shared%20Documents/SourceFolder/YourFile.xlsx")
    
    If sourcePath = "" Then Exit Sub
    
    targetPath = InputBox("コピー先フォルダのSharePointパスを入力してください:", _
                         "ターゲットフォルダパス", _
                         "https://yourcompany.sharepoint.com/sites/yoursite/Shared%20Documents/TargetFolder/")
    
    If targetPath = "" Then Exit Sub
    
    ' パスの末尾に"/"がない場合は追加
    If Right(targetPath, 1) <> "/" Then
        targetPath = targetPath & "/"
    End If
    
    ' メインの処理を実行
    Call CopyAndUpdateExcelFileInSPO
End Sub