Question

我正在尝试从其他4个工作簿中提取数据（其中一些可能数千行）

Excel完成提取后停止工作并重新启动。我已经在工作表中提取了数据，因此我假设在提取最后一个工作簿数据后，excel正在崩溃。

我还测试了只有一个工作簿，并在关闭后崩溃。

我已经读过，我们可以在复制/粘贴或关闭工作簿后使用“DoEvents”和“Application.Wait”，让Excel完成一些后台工作。我试过了，但没有成功。

为什么Excel停止运行/重启的想法？

这是我的代码：

Public sysExtractParamsDictionary As Scripting.dictionary

'Sub rotine triggered when pressing button
Sub Extract()

    Set sysExtractParamsDictionary = mUtils.FillDictionary("sysParams", "tExtractParams")   'Sub rotine belonging to mUtils module to fill dictionary with values from my sysParams sheet. Contains the sheets name.
    mClean.Clean       'Sub rotine belonging to mClean module to clear sheets
    ExtractData [sysInputDirectory], "Input Sheet"  'Cell Name sysInputDirectory
    ExtractData [sysR2Directory], "R1 Sheet"
    ExtractData [sysR2Directory], "R2 Sheet"
    ExtractData [sysR3Directory], "R3 Sheet"

End Sub

Sub ExtractData(sFilePath As String, sDictionaryKey As String)

    Dim oWorkbook As cWorkBook 'Class Module

    Set oWorkbook = New cWorkBook

    mUtils.SetStatusBarMessage True, "Extracting " & sDictionaryKey & " ..."   'Sub rotine belonging to my mUtils module to set on or off status bar message

    oWorkbook.WorkBookDirectory = sFilePath
    oWorkbook.OpenWorkBook oWorkbook.WorkBookDirectory
    oWorkbook.CopiesSourceSheetValuesToDestinationSheet sysExtractParamsDictionary(sDictionaryKey)
    oWorkbook.CloseWorkBook (False)

    DoEvents
    DoEvents
    Application.Wait (Now + TimeValue("0:00:05"))
    DoEvents

    Set oWorkbook = Nothing

End Sub

'#### Class Module

Private wbWorkBook As Workbook
Private sWorkBookDirectory As String
Private sWorkBookName As String
Private wsWorksheet As Worksheet

Public Property Set Workbook(wbNew As Workbook)
    Set wbWorkBook = wbNew
End Property

Public Property Get Workbook() As Workbook
    Set Workbook = wbWorkBook
End Property

Public Property Let WorkBookDirectory(sFilePath As String)
    sWorkBookDirectory = sFilePath
End Property

Public Property Get WorkBookDirectory() As String
    WorkBookDirectory = sWorkBookDirectory
End Property

Public Property Let WorkBookName(sFileName As String)
    sWorkBookName = sFileName
End Property

Public Property Get WorkBookName() As String
    WorkBookName = sWorkBookName
End Property

Public Property Set Worksheet(wsNew As Worksheet)
    Set wsWorksheet = wsNew
End Property

Public Property Get Worksheet() As Worksheet
    Worksheet = wsWorksheet
End Property

Public Property Let WorkBookDirectory(sFilePath As String)
    sWorkBookDirectory = sFilePath
End Property

Public Property Get WorkBookDirectory() As String
    WorkBookDirectory = sWorkBookDirectory
End Property

'Class Module Function to Open WorkBook
Public Sub OpenWorkBook(sFilePath As String)

    Dim oFSO As New FileSystemObject
    Dim sFileName As String
    Dim sLog As String

    sFileName = oFSO.GetFileName(sFilePath) 'Get the File Name from Path

    If sFileName = "" Then
        sLog = "Error. Not possible to retrieve File Name from Directory."
    Else
        Me.WorkBookName = sFileName
        Set Me.Workbook = Workbooks.Open(sFilePath)
        If wbWorkBook Is Nothing Then
            sLog = "Error opening file: " & Me.WorkBookName
        Else
            sLog = "File successfully openned!"
        End If
    End If

    Set oFSO = Nothing

End Sub

'Class Module Function to Copy Values from source to destination
Public Sub CopiesSourceSheetValuesToDestinationSheet(wsDestinationName As Variant)

    Dim wsDestination As Worksheet
    Dim rStartRange As range
    Dim rFullRangeToPaste As range

    Set wsDestination = ThisWorkbook.Sheets(CStr(wsDestinationName)) ' Destination Sheet
    Set Me.Worksheet = Me.Workbook.Sheets(1) 'Source Sheet

    Set rStartRange = wsWorksheet.range("A1")
    Set rFullRangeToPaste = wsWorksheet.range(rStartRange, mUtils.FindLast(3)) 'FindLast is a function belonging to mUtils module to find the last cell in worksheet
    rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)

End Sub

'Class Module Function to Close Workbook
Public Sub CloseWorkBook(bSaveChanges As Boolean)
    wbWorkBook.Saved = True
    wbWorkBook.Close SaveChanges:=False
End Sub

 '#### End Class Module

我也试过没有类模块（以防万一对象有问题），但我仍然有同样的问题。

Sub Extract()
 ExtractCopyClose "C:\MyFiles\InputData.csv", "Input"
End Sub

Sub ExtractCopyClose(sFilePath As String, wsDestinationName As String)

    Dim wb As New Workbook
    Dim wsDestination As Worksheet
    Dim wsSource As Worksheet
    Dim oFSO As New FileSystemObject
    Dim sLog As String
    Dim rStartRange As range
    Dim rFullRangeToPaste As range

    sFileName = oFSO.GetFileName(sFilePath) 'Get the File Name from Path

    If sFileName = "" Then
        sLog = "Error. Not possible to retrieve File Name from Directory."
    Else
        Set wb = Workbooks.Open(sFilePath)
        If wb Is Nothing Then
            sLog = "Error opening file: " & sWorkBookName
        Else
            sLog = "File successfully openned!"
        End If
    End If

    Set oFSO = Nothing

    Set wsDestination = ThisWorkbook.Sheets(wsDestinationName) ' Destination Sheet
    Set wsSource = wb.Sheets(1) 'Source Sheet

    Set rStartRange = wsSource.range("A1")
    Set rFullRangeToPaste = wsSource.range(rStartRange, mUtils.FindLast(3))
    rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)

    wb.Saved = True
    wb.Close SaveChanges:=False

End Sub

Answer 1

我发现从其他工作簿导入的工作表有外部连接，并在我的工作簿中创建了Connections和新的References。不知道为什么，但不知怎的，这影响了我的Excel并导致它重新启动，因为我复制了所有的工作表内容。

而不是将完整的源表复制到我的工作簿......

 rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)

我只复制了源表的值和格式......

Dim rDestinationRange As Range

'the rest of the code in question

~~rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)~~

   Set rDestinationRange = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
    rFullRangeToPaste.Copy    
    wsDestination.PasteSpecial xlPasteValuesAndNumberFormats

注意：这在我的工作簿从之前的提取中恢复之后起作用（没有破坏的外部连接和空引用）。然后我在代码中进行了更改并保存。

VBA：Excel从其他工作簿中提取数据后停止工作

1 个答案: