Excel文件在运行代码时崩溃并关闭，但是当我重新打开文件时代码的结果。

Question

我正在复制列下的数据，在源表和目标表之间具有匹配的标头。这两个工作表都在同一个excel文件中，但它们需要一个澄清号。

例如，目标表中的一个列具有澄清号QM6754和QM6754的行数据。源表也有澄清号列，但是我不想复制它，我想要将这个特定澄清号行中的其他数据复制到它的一个列中的目标表中。这样，数据就不会被随机复制，每个工作表中的整行都相互关联。

我使用的代码显示结果(我修改了它)，但是当我运行它时，excel文件显示(没有响应)大约3-4分钟，然后关闭或留下一个空白Excel表和VBA窗口。我关闭excel文件并重新打开它，数据已被复制。该文件相当大，我有三个按钮，为我想要复制数据的每个工作表运行这段代码。三张平均为3k-6k行的床单。但我不能排除这几行。

代码运行，但我想优化它的运行方式，因为这是不切实际的运行，关闭文件，然后再打开文件。问题是否与For循环有关？

Sub CopyColumnData()
    
    Dim wb As Workbook
    Dim myworksheet As Variant
    Dim workbookname As String
    
    
    ' DECLARE VARIABLES
    Dim i As Integer            ' Counter
    Dim j As Integer            ' Counter
    Dim colsSrc As Integer      ' PR Report: Source worksheet columns
    Dim colsDest As Integer     ' Open PR Data: Destination worksheet columns
    Dim rowsSrc As Long         ' Source worksheet rows
    Dim WsSrc As Worksheet      ' Source worksheet
    Dim WsDest As Worksheet     ' Destination worksheet
    
    Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
    Dim searchKey As String, foundKey As String
    
    workbookname = ActiveWorkbook.Name
    Set wb = ThisWorkbook
    myworksheet = "Sheet 1 copied Data"
    
    wb.Worksheets(myworksheet).Activate
    ' SET VARIABLES
    ' Source worksheet: Previous Report
    Set WsSrc = wb.Worksheets(myworksheet)
    
    Workbooks(workbookname).Sheets("Main Sheet").Activate
    ' Destination worksheet: Master Sheet
    Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
     
    'Adjust incase of change in column in both sheets
    ws1ORNum = "K"         'Clarification Number
    ws2ORNum = "K"         'Clarification Number
    ' Setting first and last row for the columns in both sheets
    ws1PRRow = 3              'The row we want to start processing first
    ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
    ws2PRRow = 3              'The row we want to start search first
    ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
    
    For i = ws1PRRow To ws1EndRow         ' first and last row
        searchKey = WsSrc.Range(ws1ORNum & i)
         'if we have a non blank search term then iterate through possible matches
        If (searchKey <> "") Then
            For j = ws2PRRow To ws2EndRow  ' first and last row
                 foundKey = WsDest.Range(ws2ORNum & j)
                  ' Copy result if there is a match between PR number and line in both sheets
                 If (searchKey = foundKey) Then
                    ' Copying data where the rows match
                        WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
                        WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
                        WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
                        WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
                        WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
                        WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
                        WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
                        WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
                        
                        
                    Exit For
                 End If
            Next
        End If
    Next
  
    
    'Close Initial PR Report file
    wb.Save
    wb.Close
    
    'Pushbuttons are placed in Summary sheet
    'position to Instruction worksheet
    ActiveWorkbook.Worksheets("Summary").Select
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select
    
    ActiveWorkbook.Worksheets("Summary").Select
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select

End Sub

Answer 1

为了提高速度和可靠性，您需要通过数组传输来处理复制/粘贴，而不是Range.Copy方法。考虑到您现有的代码，下面是应该如何为您工作的解决方案：

Sub CopyColumnData()
    
    'Source data info
    Const sSrcSheet As String = "Sheet 1 copied Data"
    Const sSrcClarCol As String = "K"
    Const lSrcPRRow As Long = 3
    
    'Destination data info
    Const sDstSheet As String = "Main Sheet"
    Const sDstClarCol As String = "K"
    Const lDstPRRow As Long = 3
    
    'Set variables based on source and destination
    On Error Resume Next
    Dim wbSrc As Workbook:  Set wbSrc = ThisWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
    Dim wbDst As Workbook:  Set wbDst = ActiveWorkbook
    Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
    On Error GoTo 0
    
    'Verify source and destination were found
    If wsSrc Is Nothing Then
        MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
        Exit Sub
    End If
    If wsDst Is Nothing Then
        MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
        Exit Sub
    End If
    
    'Setup variables to handle Clarification Number matching and data transfer via array
    Dim hDstClarNums As Object:     Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
    
    'Load Source data into array
    Dim rSrcData As Range:          Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
    Dim aSrcClarNums() As Variant:  aSrcClarNums = rSrcData.Value
    Dim aSrcData() As Variant:      aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value    'Transfer data from columns A:H
    
    'Prepare dest data array
    Dim rDstData As Range:          Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
    Dim aDstClarNums() As Variant:  aDstClarNums = rDstData.Value
    Dim aDstData() As Variant:      aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value  'Destination will be into columns AI:AP
    
    'Use dictionary to perform Clarification Number matching
    Dim vClarNum As Variant
    For Each vClarNum In aDstClarNums
        If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
    Next vClarNum
    
    'Transfer data from source to destination using arrays
    Dim i As Long, j As Long
    For i = 1 To UBound(aSrcClarNums, 1)
        For j = 1 To UBound(aSrcData, 2)
            If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
        Next j
    Next i
    
    'Output to destination
    Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
    
    'Save and close source workbook (uncomment next line if this is necessary)
    'wbSrc.Close SaveChanges:=True
    
    'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
    'wbDst.Worksheets("Summary").Activate
    'wbDst.Worksheets("Summary").Range("A1").Select
    
End Sub