0

我的 vba 代码有问题，感觉很奇怪。我正在尝试在使用 Mkdir 函数创建的特定文件夹中添加一个新工作簿。我允许用户创建文件夹并在其中一个文件夹中创建这个新工作簿。当我将文件夹保存在本地桌面时，该代码有效。但是，当我将文件夹保存在保存在本地目录中的 OneDrive 位置（不通过浏览器访问）时，它会引发运行时错误 - “对象 '_Workbook' 的方法 'SaveAs' 失败”。当我到达 NwBook.SaveAs FileName:=NewFldrPath2 & InputFrmFormat, FileFormat:=xlOpenXMLWorkbook 时会发生这种情况。更奇怪的是，当进入调试器模式并尝试逐行执行时，代码工作正常。

Sub CreateFolders()
  Dim FldrPath As String, MainFldrCheck As String, QuestionsFldr As String, InputFrmFldr As String, NewFldrPath As String
  Dim FldrName As String, NewFldrPath2 As String, InputFrmFormat As String
  Dim cell As Range, FldrRange As Range, lastRow As Range
  Dim MainFldrName As Variant
  Dim NwBook As Workbook
  Dim sh As Worksheet
  
  On Error GoTo Handle
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
      
  Set lastRow = ThisWorkbook.Worksheets("Folder Structure").Cells(Rows.Count, 2).End(xlUp)
  Set FldrRange = ThisWorkbook.Worksheets("Folder Structure").Range("B4", lastRow)
  QuestionsFldr = ThisWorkbook.Worksheets("Folder Structure").Range("B6").Value
  InputFrmFldr = ThisWorkbook.Worksheets("Folder Structure").Range("B5").Value
  
  With Application.FileDialog(4)
     .AllowMultiSelect = False
     If .Show <> -1 Then Exit Sub
     FldrPath = .SelectedItems(1)
  End With
  
  MainFldrName = InputBox("Please enter the main folder name", "Enter Main Folder Name")
  MainFldrCheck = Dir(FldrPath & "\" & MainFldrName, vbDirectory)
  
  NewFldrPath = FldrPath & "\" & MainFldrName
  NewFldrPath2 = FldrPath & "\" & MainFldrName & "\" & InputFrmFldr
  InputFrmFormat = "\Input Forms.xlsx"
  
  If MainFldrCheck = VBA.Constants.vbNullString Then
    MkDir (FldrPath & "\" & MainFldrName)
  Else
    MsgBox "The folder named " & MainFldrName & " exists, please enter a new name", , "Folder Exists"
    Exit Sub
  End If
  For Each cell In FldrRange
    FldrName = cell.Value
    MkDir (FldrPath & "\" & MainFldrName & "\" & FldrName)
    
    If FldrName = QuestionsFldr Then
      MkDir (FldrPath & "\" & MainFldrName & "\" & FldrName & "\Questions")
      MkDir (FldrPath & "\" & MainFldrName & "\" & FldrName & "\Responses")
    End If
    
   If FldrName = InputFrmFldr Then
      Set NwBook = Workbooks.Add
        NwBook.SaveAs FileName:=NewFldrPath2 & InputFrmFormat, FileFormat:=xlOpenXMLWorkbook
        NwBook.Sheets.Add After:=ActiveSheet, Count:=3
        NwBook.Sheets(1).Name = "Input Form"
        NwBook.Sheets(2).Name = "Pr Form"
        NwBook.Sheets(3).Name = "In Pr Form"
        NwBook.Sheets(4).Name = "Other Form"
        NwBook.Save
        NwBook.Close
    End If
    
  Next cell 
  
  MsgBox "Folders Created Successfully", , "Success!"
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
      
  Exit Sub
    
Handle:
  MsgBox "Error, please contact admin", , "Error"
    
End Sub
4

0 回答 0