Excel RT-1004将数据从目标工作簿复制到源工作簿时_Excel_Runtime Error_Excel 2007_Vba

Excel RT-1004将数据从目标工作簿复制到源工作簿时

excel vba

Excel RT-1004将数据从目标工作簿复制到源工作簿时,excel,runtime-error,excel-2007,vba,Excel,Runtime Error,Excel 2007,Vba,我使用此代码从工作簿复制数据，该工作簿是从报表导入的。但是，随着月份的进展和数据量的增加，运行此sub的时间也会增加（在1月的最后一周，处理900行数据需要3分钟）：我已经包括了源数据和目标工作簿的两个快照此子项用于在复制/粘贴之前清除所有过滤器 Sub Unfilter() Dim she As Variant For Each she In ThisWorkbook.Worksheets If she.FilterMode Then she.ShowAllData Next

我使用此代码从工作簿复制数据，该工作簿是从报表导入的。但是，随着月份的进展和数据量的增加，运行此sub的时间也会增加（在1月的最后一周，处理900行数据需要3分钟）：

我已经包括了源数据和目标工作簿的两个快照

此子项用于在复制/粘贴之前清除所有过滤器

Sub Unfilter()

Dim she As Variant
For Each she In ThisWorkbook.Worksheets
    If she.FilterMode Then she.ShowAllData
Next

End Sub

尝试此代码（在工作簿的临时副本上）：

Sub-Extract\u Sort\u 1602\u二月（）
暗淡和漫长
变暗LR为长
暗燃范围
把她当作工作表
ANS=MsgBox（“2016年2月的旋转主文件是否已从SharePoint签出并当前已在此桌面上打开？”，vbYesNo+vbQuestion+vbDefaultButton1，“主文件已打开”）
如果ANS=vbNo或IsWBOpen（“旋转-主控-2016年2月”）=False，则
MsgBox“所需工作簿当前未打开。此过程现在将终止。”，vbOKOnly+VBEQUOTE，“终止过程”
出口接头
如果结束
将源工作簿设置为工作簿
设置sourceWorkBook=工作簿（“TEMPIMPORT.xlsx”）
将目标工作簿设置为工作簿
设置目标工作簿=工作簿（“旋转-主控-2016年2月.xlsm”）
将源工作表设置为工作表
Set sourceWorksheet=sourceWorkBook.Sheets（“提取”）
Dim destinationWorksheet作为工作表
设置destinationWorksheet=destinationWorkbook.Sheets（“旋转”）
Application.ScreenUpdating=False
Application.EnableEvents=False
Application.Calculation=xlCalculationManual
'此行自动拟合C、D、O和P列
sourceWorksheet.Range（“C:C，D:D，O:O，P:P”）.Columns.AutoFit
'这将取消隐藏任何隐藏行
sourceWorksheet.Cells.EntireRow.Hidden=False
对于LR=sourcesheet.Range（“B”和Rows.Count）。结束（xlUp）。行到2步骤-1
如果sourcesheet.Range（“B”和LR）.值为“2”，则
如果uRng什么都不是，那么
Set uRng=sourcesheet.Rows（LR）
其他的
设置uRng=Union（uRng，sourceWorksheet.Rows（LR））
如果结束
如果结束
下一个LR
如果不是uRng，则uRng.Delete
“Application.Run”'switle-Master-2016年2月.xlsm'！Unfilter“
对于目标工作簿中的每个she。工作表
如果是she.FilterMode，则是she.ShowAllData
下一个
使用sourceWorksheet.Sort
索特菲尔德
清楚的
.Add Key:=Range（“B2:B2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
.Add Key:=Range（“D2:D2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
.Add Key:=Range（“O2:O2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
.Add Key:=Range（“J2:J2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
.Add Key:=Range（“K2:K2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
.Add键：=Range（“L2:L2000”）、SortOn:=xlSortOnValues、Order:=xlAscending、DataOption:=xlSortNormal
以
.SetRange范围（“A2:AE2000”）
.申请
以
sourceWorksheet.Cells.WrapText=False
将最后一行设置为整数
lastRow=sourcesheet.Range（“A”&Rows.Count）.End（xlUp）.Row
'将sourceRow设置为整数
Dim destinationRow作为整数
destinationRow=destinationWorksheet.Cells（Rows.Count，1）.End（xlUp）.Row+1
sourceWorksheet.Range（“A2:AA”和lastRow）。复制destinationWorksheet.Range（“A”和destinationRow）
'对于sourceRow=2到lastRow
'如果单元格（sourceRow，2）=“2”，则
'destinationWorksheet.Rows（destinationRow）=sourceWorksheet.Rows（sourceRow）'这是发生运行时错误的地方
'destinationRow=destinationRow+1
"完"
'下一个sourceRow
调用提取保存
Application.ScreenUpdating=True
Application.EnableEvents=True
Application.Calculation=xlCalculationAutomatic
端接头

destinationWorksheet.Rows（destinationRow）=sourceWorksheet.Rows（sourceRow）.Value是否会出现相同的错误？destinationWorksheet是否受保护？范围是否经过过滤或包含多个

区域

？错误描述是什么？请编辑你的问题，除了数字外，还要加上说明。@ScottHoltzman我已经用完整的错误编辑了这篇文章message@DavidZemens两个工作簿中均未启用保护。sub中有一行运行目标工作簿中的未过滤sub:

Application.Run“'switle-Master-2016年2月.xlsm”！unfilter”

在尝试复制/粘贴之前。如@DavidZemens所建议的，在每条语句的末尾尝试使用

.Value

。如果失败，请选择

destinationsheet.Rows（destinationRow）。选择和sourcesheet.Rows（sourceRow）。选择并查看它们是否按预期工作。将这些放在值复制行之前。或者直接在窗口。再次谢谢你……我的朋友。对整个过程进行了测试，结果非常理想。我知道你做了什么。我还尝试用“A2:AA”&lastRow
定义范围，但没有用.Copy
。我还在1月份的文件中测试了这个范围（处理这个文件需要3分钟，并且开始时代码更改的原因），结果在一瞬间完成。@IronMan，欢迎您，我的朋友。我很高兴这段代码有帮助，但我忘了将所有Integer
更改为Long
，因为Long更快，请参见以下链接：。
Sub Extract_Sort_1602_February()

Dim ANS As Long

ANS = MsgBox("Is the February 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
If ANS = vbNo Or IsWBOpen("Swivel - Master - February 2016") = False Then
    MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
    Exit Sub
End If

Application.ScreenUpdating = False

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "2" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR

Application.Run "'Swivel - Master - February 2016.xlsm'!Unfilter"

   With sourceWorksheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange Range("A2:AE2000")
        .Apply
    End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select

Dim sourceWorkBook As Workbook
Set sourceWorkBook = Workbooks("TEMPIMPORT.xlsx")
Dim destinationWorkbook As Workbook
Set destinationWorkbook = Workbooks("Swivel - Master - February 2016.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
Dim destinationWorksheet As Worksheet
Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")
Dim lastRow As Integer
lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
Dim sourceRow As Integer
Dim destinationRow As Integer
destinationRow = destinationWorksheet.Cells(Rows.Count, 1).End(xlUp) + 1


For sourceRow = 2 To lastRow
    If Cells(sourceRow, 2) = "2" Then
        destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow) ' This is where the Run-Time error occurs
        destinationRow = destinationRow + 1
    End If
Next sourceRow

Call ExtractSave

Application.ScreenUpdating = True
End Sub

destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow)

Sub Unfilter()

Dim she As Variant
For Each she In ThisWorkbook.Worksheets
    If she.FilterMode Then she.ShowAllData
Next

End Sub

Sub Extract_Sort_1602_February()

Dim ANS As Long
Dim LR As Long
Dim uRng As Range
Dim she As Worksheet

 ANS = MsgBox("Is the February 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
 If ANS = vbNo Or IsWBOpen("Swivel - Master - February 2016") = False Then
     MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
     Exit Sub
 End If

Dim sourceWorkBook As Workbook
 Set sourceWorkBook = Workbooks("TEMPIMPORT.xlsx")
Dim destinationWorkbook As Workbook
 Set destinationWorkbook = Workbooks("Swivel - Master - February 2016.xlsm")
Dim sourceWorksheet As Worksheet
 Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
Dim destinationWorksheet As Worksheet
 Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

    ' This line autofits the columns C, D, O, and P
    sourceWorksheet.Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    sourceWorksheet.Cells.EntireRow.Hidden = False



    For LR = sourceWorksheet.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If sourceWorksheet.Range("B" & LR).Value <> "2" Then
         If uRng Is Nothing Then
          Set uRng = sourceWorksheet.Rows(LR)
         Else
          Set uRng = Union(uRng, sourceWorksheet.Rows(LR))
         End If
        End If
    Next LR

    If Not uRng Is Nothing Then uRng.Delete

    'Application.Run "'Swivel - Master - February 2016.xlsm'!Unfilter"
    For Each she In destinationWorkbook.Worksheets
        If she.FilterMode Then she.ShowAllData
    Next



   With sourceWorksheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange Range("A2:AE2000")
        .Apply
    End With

    sourceWorksheet.Cells.WrapText = False

    Dim lastRow As Integer
    lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
    'Dim sourceRow As Integer
    Dim destinationRow As Integer
    destinationRow = destinationWorksheet.Cells(Rows.Count, 1).End(xlUp).Row + 1


    sourceWorksheet.Range("A2:AA" & lastRow).Copy destinationWorksheet.Range("A" & destinationRow)

    'For sourceRow = 2 To lastRow
    '    If Cells(sourceRow, 2) = "2" Then
    '        destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow) ' This is where the Run-Time error occurs
    '        destinationRow = destinationRow + 1
    '    End If
    'Next sourceRow

    Call ExtractSave

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub