将复制的列表粘贴到一行的最后

Question

目前，我只能复制并粘贴一行中的内容。

我使用以下代码：

        Dim lastRow As Long

    With Sheets("Tab1")
        If Application.WorksheetFunction.CountA(.Columns(3)) <> 0 Then
            lastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
        Else
            lastRow = 1
        End If

        Sheets("Tabelle2").Range("B85:S85").copy

        .Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End With

我的问题是我需要复制和粘贴列表。 有人可以告诉我如何使用此代码复制并粘贴列表吗？

我想复制更多行，例如(A25:S25, A27:S27, A30:S30)

它应始终复制相同的行。

Answer 1

您的代码仅复制一行有两个原因：

1. 该代码仅选择要复制的一行

    Sheets("Tabelle2").Range("B85:S85").Copy 

2. 选择刚刚粘贴的行

    .Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues … 

由于目前尚不清楚您是否只选择复制一行还是将其复制到几行，所以我将同时介绍这两个选项，以使您了解在两种情况下的处理方法：

1. 设定要复制的范围

   一种。 只复制范围B85:S85仅一行，那么您所做的是正确的

    Wbk.Sheets("Tabelle2").Range("B85:S85") 

   b。 从第85行（包括第85行）向下复制X行

    Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(X) 

   C。 从第85行（包括第85行）开始复制Y行

    Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(1-Y, 0).Resize(Y) 

   d。 复制由包含“ B85：S85”的空白行和空白列的任意组合限制的范围（请参见Range.CurrentRegion属性（Excel） ）

    Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion 

   请注意，如果行中至少有一个非空白的单元格导致“当前区域”向上或向下延伸，则该行还将包括行85上方和下方的任何行，并且行B左侧或行B任何列也将包括在内。如果列中至少有一个单元格不为空白，导致“当前区域”向侧面延伸，则在S列的右侧

此过程演示了上面说明的选项：

Sub Range_Set()
Dim rSrc As Range

    With ThisWorkbook.Sheets("Tabelle2")

        'If want to copy just this row 85
        Application.Goto .Cells(1), 1
        Set rSrc = .Range("B85:S85")
        rSrc.Select: Stop

        'If want to copy 5 rows down from row 85 (including row 85)
        Application.Goto .Cells(1), 1
        Set rSrc = .Range("B85:S85").Resize(5)
        rSrc.Select: Stop

        'If want to copy 5 rows up from row 85 (including row 85)
        Application.Goto .Cells(1), 1
        Set rSrc = .Range("B85:S85").Offset(-4, 0).Resize(5)
        rSrc.Select: Stop

        'If want to copy then range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
        'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
        'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
        Application.Goto .Cells(1), 1
        Set rSrc = .Range("B85:S85").CurrentRegion
        rSrc.Select: Stop

    End With

End Sub

2. 设定复制发生的范围

要按原样复制源范围，则只需选择目标范围的第一个单元格，然后粘贴。 paste.special将覆盖将目标粘贴到所需大小的所有单元格。 但是，如果您要将范围B85:S85' to several cell then you need to select the target rows. For example if we want to copy复制B85:S85' to several cell then you need to select the target rows. For example if we want to copy B85:S85' to several cell then you need to select the target rows. For example if we want to copy要从C5开始B85:S85' to several cell then you need to select the target rows. For example if we want to copy五行中的B85：S85'，则需要将目标范围设置为

    .Range("C12").Resize(5).PasteSpecial Paste:=xlPasteValues

由于我们将仅复制源的值，因此建议使用Range对象的Range.Value属性，而不要使用Copy…Paste方法。 使用此属性的优点之一是避免使用剪贴板。

尝试使用此代码（根据您的要求选择\\调整选项）

Sub Range_Value()
Dim Wbk As Workbook
Dim lastRow As Long
Dim rSrc As Range

    Rem Declare Objects
    Set Wbk = ThisWorkbook          'use this if procedure is resident in the wbk with the tables
    'Set Wbk = Workbooks(WbkName)    'use this if procedure is not resident in the wbk with the tables - update wbk name

    With Wbk.Sheets("Tab1")

        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        Rem Set Copy Range
        'since we are going to paste only values then we can save us from using the clippboard
        'Sheets("Tabelle2").Range("B85:S85").Copy
        'instaed create a range to replace the values of the target range with the values of this range

        'Uncomment\Update the option needed according to you requirements
        'for this test I'm using option b

        'a. To copy just row 85
        'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85")

        'b. To copy X rows down from row 85 (including row 85) X=5
        Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(5)

        'c. To copy 5 rows up from row 85 (including row 85) Y=5
        'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(-4, 0).Resize(5)

        'd. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
        'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
        'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
        'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion

        ' As mentioned before we won't use the clipboard
        'instead we replace the values with the values of the target range created earlier
        'however we need to extend the range to the same size of the source range
        .Range("C" & lastRow + 1).Resize(rSrc.Rows.Count, rSrc.Columns.Count).Value = rSrc.Value2

    End With

End Sub

希望这足够清楚，可以帮助您在编码方面取得进步，不过，请让我知道您可能遇到的任何问题。

Answer 2

我不太确定您要寻找的是什么-但这里是如何循环的：

Sub test()
For i = 25 to 30
    Range(Cells(i,1),Cells(i,19)).Copy
    Range(Cells(i,20),Cells(i,39)).PasteSpecial xlPasteValues

Next i
End Sub

复制A25：S25并粘贴到T25：AM25 ...然后A26：S26，粘贴T26：AM26，依此类推，直到第31行。

Answer 3

既然已经公开了要求，那么我们就有机会应用另一种方法。 请记住，源范围包含多个区域这一事实可能使我们想到一系列重复的“复制粘贴值”，这会不必要地使用剪贴板或重复的范围值。

这次不是将源范围设置为对象（仍然可以完成），我们将使用Array变量来获取多区域范围的值
以便一步一步将它们作为统一而连续的范围输入目标范围。

此过程使用源范围区域的值设置一个数组，然后使用Range.Value属性将数组的值设置为目标范围。

Sub Range_MultiAreas_CopyValue()
Const kRowIni As Long = 25
Dim Wbk As Workbook
Dim aRngSrc() As Variant
Dim lRowLst As Long, l As Long, b As Byte

    Rem Declare Objects
    Set Wbk = ThisWorkbook

    Rem Set Array with rows to copy as value
    With Wbk.Sheets("Tabelle2")
        l = kRowIni
        For b = 1 To 30
            If .Range("V" & l).Value2 = 0 Then
                Rem Resize Array
                On Error Resume Next
                ReDim Preserve aRngSrc(1 + UBound(aRngSrc))
                If Err.Number <> 0 Then ReDim Preserve aRngSrc(1)
                On Error GoTo 0
                Rem Set Row Values In Array
                aRngSrc(UBound(aRngSrc)) = .Cells(l, 2).Resize(, 16).Value2
                Rem Increase Row Pointer
                l = l + 2
    End If: Next: End With

    Rem Reset Arrays Structure
    With WorksheetFunction
        aRngSrc = .Transpose(.Transpose(aRngSrc))
    End With

    Rem Let Array Values in Target Range
    With Wbk.Sheets("Tab1")
        lRowLst = .Cells(.Rows.Count, 1).End(xlUp).Row
        lRowLst = IIf(.Cells(1, 1) = Empty, 1, lRowLst + 1)
        .Cells(lRowLst, 1).Resize(UBound(aRngSrc, 1), UBound(aRngSrc, 2)).Value = aRngSrc
    End With

End Sub

再次让我知道您可能对使用的资源有任何疑问。

Answer 4

正如siddharth rout所说，由于不可能在间隔之间一次复制多行，因此我们试图通过遍历应复制并添加if查询的每一行行来绕过该问题。 此代码有效，我现在使用“他”

        j = 0

    For i = 1 To 30

        With Sheets("Arbeiter-Tage")
            If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
                lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Else
                lastRow = 1
            End If

            Sheets("Vorlage").Activate

            If ActiveSheet.Range("V" & 25 + j).Value = 0 Then

                ActiveSheet.Range("B" & 25 + j & ":" & "Q" & 25 + j).Copy

                .Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            End If

        End With

    j = j + 2