Question

我已经编写/散列了一个程序，用于复制一行数据，以便当行符合某个条件（列A =＆＃34; 1＆＃34;）时，所有工作簿都位于桌面上的测试文件夹中;该程序最初工作，但现在在这里引起错误：

ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy Destination:=ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1)

一旦对其进行了排序，我还担心这种复制和粘贴方法会粘贴公式而不是值，是否可以轻松粘贴值？

感谢您的帮助，我非常感谢！

我的代码

Option Explicit

Sub AccrualCombiner()

Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim cWkb As Workbook
Dim ws As Worksheet
Dim answer As Integer
Dim lr As Long, lr2 As Long, r As Long
Dim rc As Object

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

answer = MsgBox("Would you like to combine Accruals for current period?", vbYesNo + vbQuestion, "Confirmation")

If answer = vbYes Then
    Set cWkb = Application.ActiveWorkbook
    lr2 = ThisWorkbook.Sheets("SummaryAccrual").Cells(Rows.Count, "A").End(xlUp).Row

    Path = "C:\Users\alexander.neale\Desktop\Test"
    FileName = Dir(Path & "\*.xls", vbNormal)

    Do Until FileName = ""

        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each ws In Wkb.Worksheets
            For r = 14 To 60 Step 1
                If ws.Range("A" & r).Value = "1" Then
                    ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy Destination:=ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1)
                    lr2 = ThisWorkbook.Sheets("SummaryAccrual").Cells(Rows.Count, "A").End(xlUp).Row
                End If
            Next r
        Next ws
        Wkb.Close False
        FileName = Dir()
    Loop

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
End If

End Sub

Answer 1

因为您只对粘贴值感兴趣，所以应该更快：

Option Explicit

Sub AccrualCombiner()
    Dim Path As String
    Dim FileName As String
    Dim Wkb As Workbook
    Dim ws As Worksheet
    Dim answer As Integer
    Dim r As Long

    answer = MsgBox("Would you like to combine Accruals for current period?", vbYesNo + vbQuestion, "Confirmation")        
    If answer = vbYes Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False

        Path = "C:\Users\alexander.neale\Desktop\Test"
        With ThisWorkbook.Worksheets("SummaryAccrual")
            FileName = Dir(Path & "\*.xls", vbNormal)
            Do Until FileName = ""
                Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
                For Each ws In Wkb.Worksheets
                    If WorksheetFunction.CountIf(ws.Range(ws.Cells(14, 1), ws.Cells(60, 1)), "1") > 0 Then
                        For r = 14 To 60 Step 1
                            If ws.Range("A" & r).Value = "1" Then
                                .Cells(.Rows.COUNT, "A").End(xlUp).Offset(1).Resize(, 20).Value = ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Value
                            End If
                        Next r
                    End If
                Next ws
                Wkb.Close False
                FileName = Dir()
            Loop
        End With

        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.AskToUpdateLinks = True
    End If
End Sub

Answer 2

这是你的问题：

ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy

第二个Cells没有指定工作表，因此它会假设您指的是活动工作表。如果活动工作表不是ws，则它将失败，因为范围不能跨越多个工作表。因此使用

ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Copy

或

With ws
    .Range(.Cells(r, 1), .Cells(r, 20)).Copy ....
End With

编辑：仅粘贴值，或者只设置范围的.Value属性，例如建议用户3598756：

ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1).Resize(1, 20).Value = ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Value

或使用PasteSpecial选项使用xlPasteValues：

ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Copy
ThisWorkbook.Worksheets("SummaryAccrual").Range("A" & lr2 + 1).PasteSpecial xlPasteValues

第一个选项通常要快得多。

在VBA上复制和粘贴动态范围，错误：object_worksheet的范围，

2 个答案: