Excel自己覆盖文件覆盖

时间:2017-01-16 09:06:39

标签: excel vba excel-vba

我正在为以下算法编写Excel宏:

步骤:

1)在Outlook中循环播放电子邮件

2)将附件(excel文件)下载到特定文件夹

3)打开Excel仪表板模板

4)打开已保存的附件(excel文件)

5)将数据从附件复制到模板

6)关闭附件

7)调整模板中的数据

8)将模板另存为新工作簿

9)转到第3步,继续下一个附件

我的问题是,在第6步中,文件(附件)没有完全关闭 - 它在Project Explorer中仍然可见,因此每次我将模板excel保存为新的Dashboard.xlsx时立即用附件覆盖它。我已经搜索了解决方案,但我发现只是在附件中使用workbooks.close,这对我不起作用。

我发现完全关闭附件的唯一方法是关闭模板文件,所以看起来它们以某种方式连接。

以下是代码:

' this code gets called by a macro that downloads the attachments
Sub update_WB()

Dim main_book, att_book As Workbook
Dim lastrow, firstrow As Long
Dim att_name as string

Workbooks.Open "../template.xlsx"  ‘<- I have shorten the path for the purpose of posting

Set main_book = Application.ActiveWorkbook

main_book.Worksheets("Raw Data").Activate
main_book.Worksheets("Raw Data").Cells.Select
Selection.ClearContents
Selection.UnMerge

Application.Workbooks.Open  "../attachment.xlsx"  ‘<- I have shorten the path for the purpose of posting

Set att_book = ActiveWorkbook

att_book.Worksheets(1).Range("A:BD").Select

Selection.Copy main_book.Worksheets("Raw Data").Range("A:BD")

att_book.Close ‘<- this is where the attachment should close, but it does not. It only disappears from windows taskbar.

main_book.Worksheets("Raw Data").Activate

lastrow = Worksheets("Raw Data").Cells(Worksheets("Raw Data").Rows.Count, "A").End(xlUp).Row - 1
For firstrow = 1 To 100
    If Worksheets("Raw Data").Cells(firstrow, 1).Text = "Date" Then Exit For
Next firstrow

main_book.Worksheets("Raw Data").Activate
main_book.Worksheets("Raw Data").Cells.Select
Selection.UnMerge

main_book.Worksheets("Raw Data").Range("A" & firstrow & ":BG" & lastrow - 1).Name = "Raw_Data"


‘. 
‘.
‘.
‘. Some data manipulation –> copy, paste, delete, etc. 
‘.
‘.
‘.
‘.     

    Application.DisplayAlerts = False
    main_book.SaveAs (“../Dashboard_" & Format(Timeserial(hour(now()),minute(now()),second(now())),"hhmmss") & ".xlsx") ‘<- I have shorten the path for the purpose of posting. This is where excel does the saving twice – first it saved the main_book and then att_book, both under the same name.
    Application.DisplayAlerts = True
main_book.Close '<- this is where both of the files close entirely

End Sub

1 个答案:

答案 0 :(得分:1)

您应该替换以下内容 -

Workbooks.Open "../template.xlsx"  ‘<- I have shorten the path for the purpose of posting

Set main_book = Application.ActiveWorkbook

Set main_book = Workbooks.Add(Template:="../template.xlsx")

这会从模板中创建一个新的wb,而不仅仅是打开模板文件。

编辑:!!

还要考虑

Application.Workbooks.Open  "../attachment.xlsx"  ‘<- I have shorten the path for the purpose of posting

Set att_book = ActiveWorkbook

- &GT;

Set att_book = Application.Workbooks.Open  "../attachment.xlsx"

这可以避免无意中推荐错误的打开的书籍。

编辑2:代码的工作部分,运行并保存没有错误

Sub update_WB()

Dim main_book, att_book As Workbook
Dim lastrow, firstrow As Long
Dim att_name As String

Set main_book = Workbooks.Add(Template:="template.xlsx")  'Corrected



main_book.Worksheets("Raw Data").Activate
main_book.Worksheets("Raw Data").Cells.Select
Selection.ClearContents
Selection.UnMerge

Set att_book = Application.Workbooks.Open("attachment.xlsx")  'Corrected



att_book.Worksheets(1).Range("A:BD").Select

Selection.Copy main_book.Worksheets("Raw Data").Range("A:BD")

att_book.Close
Set att_book = Nothing 'Added pointer reset, ultimately closes the workbook

main_book.Worksheets("Raw Data").Activate

lastrow = Worksheets("Raw Data").Cells(Worksheets("Raw Data").Rows.Count, "A").End(xlUp).Row - 1
For firstrow = 1 To 100
    If Worksheets("Raw Data").Cells(firstrow, 1).Text = "Date" Then Exit For
Next firstrow

main_book.Worksheets("Raw Data").Activate
main_book.Worksheets("Raw Data").Cells.Select
Selection.UnMerge


    'Application.DisplayAlerts = False
    main_book.SaveAs ("Dashboard_" & Format(TimeSerial(Hour(Now()), Minute(Now()), Second(Now())), "hhmmss") & ".xlsx") ''<- I have shorten the path for the purpose of posting. This is where excel does the saving twice – first it saved the main_book and then att_book, both under the same name.
    'Application.DisplayAlerts = True
main_book.Close
Set mainbook = Nothing 'Ultimately closes the template

End Sub