在网络或 onedrive 文件夹上运行代码时遇到问题

问题描述

我发现了一些非常有用的代码。问题是，如果文件夹目录位于映射驱动器或 onedrive 上，这将不起作用。我已经查看了其他各种示例来改变这一点，但我被卡住了。这段代码循环遍历文件夹中的所有 Excel 表格，复制并粘贴内容，然后将它们保存在其他地方。

简而言之，我只需要此代码也能在 onedrive 或映射的网络驱动器上运行。

执行此操作的代码

Sub Work_all_excelsheets() ' Run Age Report Button
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook,WS1 As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim wbname As String,killname As String
Dim fso As New FileSystemObject
Dim myCSVPath As String,myCSVPath2 As String,myCSVPath3 As String,myCSVFileName As String,currpath As String

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

Call Declare_Sheets

With Application
    .EnableEvents = False
    .displayAlerts = False
    .ScreenUpdating = False
End With

Call Unlock_allsheets

Success2 = True
RProw = WSSS.Range("M7")
ERRrow = WSSS.Range("M6")
'In Case of Cancel
NextCode:
  myPath = ThisWorkbook.path & "\Age to Process\"
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsx*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  do while myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(filename:=myPath & myFile)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'Change First Worksheet's Background Fill Blue
    Set WS1 = wb.Worksheets("Sheet1")
    WS1.Range("A1:I1000").copy
    WSAS.Range("K11:S1010").PasteSpecial xlPasteValues
    Call Run_Action_Sheet_Service

    'Save and Close Workbook
    If Success Then
        wbname = wb.name
        currpath = wb.path
        myCSVPath = WBMAST.path & "\FINISHED"
        myCSVPath2 = myCSVPath & "\" & Year(Date)
        myCSVPath3 = myCSVPath2 & "\" & Month(Date)
        myCSVFileName = myCSVPath3 & "\" & wbname
        
        Application.displayAlerts = False
        'On Error GoTo err
        If Not fso.FolderExists(myCSVPath2) Then
            fso.CreateFolder myCSVPath2
        End If
        If Not fso.FolderExists(myCSVPath3) Then
            fso.CreateFolder myCSVPath3
        End If
        Application.Wait (Now + TimeValue("0:00:03"))
        Call Protect_allsheets(wb)
        With wb
        .SaveAs filename:=myCSVFileName,FileFormat:=61,CreateBackup:=False
        .Close
        End With
        killname = currpath & "\" & wbname
        Kill killname
        
    Else
        wb.Close Savechanges:=False
    End If
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

err:

ResetSettings:
  'Reset Macro Optimization Settings
    Application.Calculation = xlCalculationAutomatic

' Add names and email adresses to Outstanding units

Call Add_Customer_Details

With Application
    .EnableEvents = True
    .displayAlerts = True
    .ScreenUpdating = True
End With

If Success2 = False Then
    MsgBox ("There were errors with some of the Files. Please check the Err Report and the Age to Process folder.")
    WSError.Activate
Else
    MsgBox "Task Complete!"
End If

Call Create_Protection

'Unlock the columns for the report
Dim Exists5 As Boolean

'First check if the sheet exists
For I = 1 To WBMAST.Worksheets.Count
    If WBMAST.Worksheets(I).name = WSReport.name Then Exists5 = True
Next I
If Exists5 Then
    WSReport.Unprotect Password:="XXXXXX"
    With WSReport
        .Activate
        .Protection.AllowEditRanges.Add Title:="Allow_ChangesWS1",Range:=.Range("O3:P5000")
        .Protect Password:="XXXXXX"
    End With
End If
    


End Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

excel excel network-drive