Outlook 宏创建的新 Excel 工作簿未保存在目录中

Question

我有一个 Outlook 宏，可以将用户 Tasklist 导出到存储在网络驱动器上的 Excel 电子表格中。

我正在尝试检查目录中是否已存在工作簿 (If statement taken form here)。

如果没有，则用一个名为“Sheet 1”的工作表创建一个新工作簿，如果已经有一个具有正确用户名的工作表，则打开它 (add statement taken from here)：

感谢SO，我已经修复了我遇到的命名错误，但是现在新创建的工作簿没有保存在目录文件夹中。没有抛出错误，并且宏末尾的消息框显示正确，所以我不知道为什么文件没有显示在文件资源管理器中。

这是我的整个程序：

Sub Task_Grab_V2()
  Dim sKillExcel As String
  Dim strReport As String
  Dim olnameSpace As Outlook.NameSpace
  Dim taskFolder As Outlook.MAPIFolder
  Dim tasks As Outlook.Items
  Dim tsk As Outlook.TaskItem
  Dim objExcel As New Excel.Application
  Dim exWb As Excel.Workbook
  Dim sht As Excel.Worksheet
  Dim NAME_s As String
  Dim Range As Excel.Range
  Dim str As String, strClean As String
  Dim z As Integer
  Dim strMyName As String
  Dim x As Integer
  Dim y As Integer
  Dim stat_string As String
Dim r As Range, s As String, iloc As Long
Dim s1 As String, cell As Range, col As Long
Dim sChar As String
Dim strUserName As String

 objExcel.DisplayAlerts = False
 'Use the Application Object to get the Username
 NAME_s = Environ("USERNAME")

 Dim FilePath As String
    Dim TestStr As String

    FilePath = "some\directory" & NAME_s & ".xlsx"

    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        Set exWb = objExcel.Workbooks.Add(1)
        exWb.Sheets("Sheet1").Name = "Sheet1Old"
        exWb.Sheets.Add().Name = "Sheet1"
        exWb.Sheets("Sheet1Old").Delete
    Else
        Set exWb = objExcel.Workbooks.Open("some\directory" & NAME_s & ".xlsx")
          exWb.Sheets.Add().Name = "Sheet1"
          exWb.Sheets("Sheet1_old").Delete
    End If




  Set olnameSpace = Application.GetNamespace("MAPI")
  Set taskFolder = olnameSpace.GetDefaultFolder(olFolderTasks)

  Set tasks = taskFolder.Items

  strReport = ""

  'Create Header
  exWb.Sheets("Sheet1").Cells(1, 1) = "Subject"
  exWb.Sheets("Sheet1").Cells(1, 2) = "Category"
  exWb.Sheets("Sheet1").Cells(1, 3) = "Due Date"
  exWb.Sheets("Sheet1").Cells(1, 4) = "Percent Complete"
  exWb.Sheets("Sheet1").Cells(1, 5) = "Status"
  exWb.Sheets("Sheet1").Cells(1, 6) = "Notes"


  y = 2

  For x = 1 To tasks.Count

       Set tsk = tasks.Item(x)

       'strReport = strReport + tsk.Subject + "; "

       'Fill in Data
       If Not tsk.Complete Then

            If tsk.Status = olTaskDeferred Then
                stat_string = "Deferred"
            End If
            If tsk.Status = olTaskInProgress Then
                stat_string = "In Progress"
            End If
            If tsk.Status = olTaskNotStarted Then
                stat_string = "Not Started"
            End If
            If tsk.Status = olTaskWaiting Then
                stat_string = "Waiting on Someone Else"
            End If




        exWb.Sheets("Sheet1").Cells(y, 1) = tsk.Subject
        exWb.Sheets("Sheet1").Cells(y, 2) = tsk.Categories
        exWb.Sheets("Sheet1").Cells(y, 3) = tsk.DueDate
        exWb.Sheets("Sheet1").Cells(y, 4) = tsk.PercentComplete
        exWb.Sheets("Sheet1").Cells(y, 5) = stat_string
        exWb.Sheets("Sheet1").Cells(y, 6) = tsk.Body

   'the following section searches the body of the task for a specified character and deletes everything after it
        col = 6   ' assumes column 6, change to your column
sChar = "#" ' assume character to look for is hash, change to yours
With objExcel.ActiveSheet
  Set r = .Range(.Cells(2, col), .Cells(.Rows.Count, col).End(xlUp))
End With
For Each cell In r
 s = cell.Text
 If Len(Trim(s)) > 0 Then
   iloc = InStr(1, s, sChar, vbTextCompare)
   If iloc > 1 Then
     s1 = Left(s, iloc - 1)
     cell.Value = s1
   Else
     If iloc <> 0 Then
      cell.ClearContents
     End If
   End If
 End If
Next cell
        y = y + 1
        stat_string = ""
       End If

  Next x


'Autofit all column widths
On Error Resume Next
For Each sht In objExcel.ActiveWorkbook.Worksheets
    sht.Columns("A").EntireColumn.AutoFit
    sht.Columns("B").EntireColumn.AutoFit
    sht.Columns("C").EntireColumn.AutoFit
    sht.Columns("D").EntireColumn.AutoFit
    sht.Columns("E").EntireColumn.AutoFit
    sht.Columns("F").EntireColumn.AutoFit
Next sht

exWb.Save

exWb.Close

Set exWb = Nothing
'this kills the excel program from the task manager so the code will not double up on opening the application
sKillExcel = "TASKKILL /F /IM Excel.exe"
Shell sKillExcel, vbHide

MsgBox ("Tasks have been sucessfully exported.")


End Sub

谁能明白为什么上面的代码不会保存创建的文件？

Answer 1

您将工作簿保存在此处：

exWb.Save

如果工作簿是在此处创建的：

If TestStr = "" Then
    Set exWb = objExcel.Workbooks.Add(1)

那么您没有指定工作簿的文件名，因此如果它是 Book1，那么您的 我的文档 文件夹中很可能有一个新的 Book1.xlsx 文件。

如果已经有一个Book1.xlsx 文件，objExcel 实例会弹出一个警报：

我需要在这里做一个假设，但我的理论是¹objExcel是一个Excel应用程序实例，它被创建为“在后台运行”，它不可见。但即使应用程序不可见，通常您也会看到那个警告框。除非您明确禁用它：

objExcel.DisplayAlerts = False

禁用警报后，Save 只会覆盖现有文件。

所以您没有收到任何错误，但该文件不在您预期的文件夹中，也没有您保存它的文件名，但它是创建的。

如果您想将文件保存在指定路径/​​文件名下，请使用SaveAs 方法而不是Save - but that's no news。

---

_{¹its just declared as Dim objExcel As New Excel.Application. – scb998 2 mins ago}

Answer 2

您需要在exWb.Sheets("Sheet1Old").Delete

旁边添加exWb.SaveAs Filename:=FilePath

例子

    Set exWb = objExcel.Workbooks.Add(1)
    exWb.Sheets("Sheet1").Name = "Sheet1Old"
    exWb.Sheets.Add().Name = "Sheet1"
    exWb.Sheets("Sheet1Old").Delete
    exWb.SaveAs FileName:=FilePath