时间戳

首页 > 解决方案 > 宏不会将工作表复制并粘贴到服务器位置上的另一个工作簿

excel - 宏不会将工作表复制并粘贴到服务器位置上的另一个工作簿

问题描述

一直在研究宏以从主工作簿复制工作表并将它们粘贴到另一个位置的临时工作簿中以保存为工作簿并添加到电子邮件以在删除之前发送。

我昨晚终于破解了它，它在我的机器（Excel 2013）上运行良好，但是当我把它放在我的机器上工作并将文件夹目标更改为我们共享驱动器（Excel 2010）上的各自位置时，宏冻结在宏的复制/粘贴部分，我不知道为什么？如前所述，以下在我的 PC 上运行良好。

{Sub LatestUpdates()
 
    Dim FName           As String
    Dim FPath           As String
    Dim NewBook         As Workbook
    Dim Ws              As Worksheet
    
    Application.DisplayAlerts = False
 
    FPath = "C:\Temp"
    FName = "Latest Spreadsheet for Details" & " " & Format(Date, "dd-mm-yyyy")
 
    Set NewBook = Workbooks.Add
 
    ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", _
        "Sheet8", "Sheet9", "Sheet10")).Copy Before:=NewBook.Sheets(1)
        
    Worksheets("Sheet1").Delete
    Set Ws = Worksheets("Sheet1 (2)")
    Ws.Name = "Sheet1"

    Worksheets("Sheet1").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet2").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet3").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet4").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet5").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet6").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet7").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet8").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet9").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet10").Select
    ActiveSheet.Buttons.Delete
    
    Sheets("Sheet1").Activate
 
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlOpenXMLWorkbook
        
Call MAILDan
    
Application.DisplayAlerts = True

ActiveWorkbook.Close

Kill "C:\Temp\*.xl*"
 
End Sub}

但是服务器上的这个没有并在复制/粘贴阶段停止？

{Sub LatestUpdates()
 
    Dim FName           As String
    Dim FPath           As String
    Dim NewBook         As Workbook
    Dim Ws              As Worksheet
    
    Application.DisplayAlerts = False
 
    FPath = "S:\Shared Drive\That Folder\LatestUpdates"
    FName = "Latest Spreadsheet for Details" & " " & Format(Date, "dd-mm-yyyy")
 
    Set NewBook = Workbooks.Add
 
    **ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", _
        "Sheet8", "Sheet9", "Sheet10")).Copy Before:=NewBook.Sheets(1)**
        
    Worksheets("Sheet1").Delete
    Set Ws = Worksheets("Sheet1 (2)")
    Ws.Name = "Sheet1"

    Worksheets("Sheet1").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet2").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet3").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet4").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet5").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet6").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet7").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet8").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet9").Select
    ActiveSheet.Buttons.Delete
    Worksheets("Sheet10").Select
    ActiveSheet.Buttons.Delete
    
    Sheets("Sheet1").Activate
 
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlOpenXMLWorkbook
        
Call MAILDan
    
Application.DisplayAlerts = True

ActiveWorkbook.Close

Kill "S:\Shared Drive\That Folder\LatestUpdates\*.xl*"
 
End Sub}

任何关于它为什么不起作用的帮助将不胜感激。

非常感谢

标签： excelvba

解决方案

您可以将工作簿本地保存到临时文件夹，而不是将工作簿保存到共享驱动器上的文件夹。

以下代码将执行此操作，但您可能需要调整MAILDan中的代码以在将新工作簿附加到电子邮件时引用正确的路径。

Sub LatestUpdates()
Dim NewBook As Workbook
Dim Ws As Worksheet
Dim FName As String
Dim FPath As String

    Application.DisplayAlerts = False

    FPath = GetTempFolder
    FName = "Latest Spreadsheet for Details" & " " & Format(Date, "dd-mm-yyyy")

    Set NewBook = Workbooks.Add

    ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", _
                              "Sheet8", "Sheet9", "Sheet10")).Copy
                              
    Set NewBook = ActiveWorkbook
    
    For Each Ws In NewBook.Sheets
        Ws.Buttons.Delete
    Next Ws

    Sheets("Sheet1").Activate

    NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlOpenXMLWorkbook

    Call MAILDan

    Application.DisplayAlerts = True

    FPath = NewBook.FullName#
    
    NewBook.Close

    Kill FPath

End Sub

Function GetTempFolder()
Dim FSO As Object, TmpFolder As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TmpFolder = FSO.GetSpecialFolder(2)
    GetTempFolder = TmpFolder

End Function

推荐阅读