Fatal编程技术网
  • vba/
  • Vba 将复制的列表粘贴到行尾

Vba 将复制的列表粘贴到行尾

vba excel

Vba 将复制的列表粘贴到行尾,vba,excel,Vba,Excel,目前我只能从一行复制粘贴内容 我使用以下代码： 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

目前我只能从一行复制粘贴内容

我使用以下代码：

        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

Dim lastRow尽可能长
附页（“表1”）
如果Application.WorksheetFunction.CountA（.Columns（3））为0，则
lastRow=.Cells（Rows.Count，“C”）.End（xlUp）.行+1
其他的
lastRow=1
如果结束
图纸（“表2”）。范围（“B85:S85”）。副本
.Range（“C”和lastRow）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，skipblank_
：=假，转置：=假
以
我的问题是我需要复制和粘贴列表。有人能告诉我如何使用此代码复制和粘贴列表吗

我想复制更多的行，比如
（A25:S25，A27:S27，A30:S30）

它应该总是复制相同的行

代码只复制一行有两个原因：

  • 代码只选择一行进行复制

    Sheets("Tabelle2").Range("B85:S85").Copy
  • 选择要粘贴的行

    .Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues …
    • 由于不清楚您是只选择一行还是将一行复制到多行，因此我将介绍这两个选项，以便让您了解在这两种情况下应该做什么：

  • 设置要复制的范围

    a。仅复制一行范围
    B85:S85

    Wbk.Sheets("Tabelle2").Range("B85:S85")
    b。从第85行（包括第85行）向下复制X行的步骤

    c。从第85行（包括第85行）向上复制Y行的步骤

    d。复制包含“B85:S85”的空白行和空白列的任意组合所限定的范围（请参阅）

    请注意，如果行
    85
    上方和下方至少有一个非空单元格导致“当前区域”，则这也将包括这些行向上或向下延伸，它还将包括列
    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
  • 设置进行复制的范围
    • 要按原样复制源区域，则只需选择目标区域的第一个单元格，然后粘贴
    。特殊的
    将根据所有目标单元格的大小将目标粘贴到所需的所有单元格。但是，如果要将范围
    B85:S85'复制到多个单元格，则需要选择目标行。例如，如果我们想从
    C5
    开始在五行上复制
    B85:S85'，那么我们需要将目标范围设置为
    

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

    
由于我们只复制源的值，我建议使用Range对象的
    Range.Value
    属性，而不是
    copy…Paste
    方法。使用此属性的一个优点是避免使用剪贴板
    
尝试此代码（根据您的要求选择\调整选项）
    

    希望这足够清楚，并有助于您在编码方面取得进展，但请告诉我您可能遇到的任何问题。
    我不太确定您在寻找什么，但这里的“如何循环：
    

    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行。
    因为当间隙之间存在间隙时，不可能一次复制多行，正如siddharth rout所说，我们试图绕过循环通过每个应复制的单行并添加if查询的问题。
这个代码正在运行，我现在正在使用“他”
    

    j=0
对于i=1到30
带床单（“Arbeiter Tage”）
如果Application.WorksheetFunction.CountA（.Columns（1））为0，则
lastRow=.Cells（Rows.Count，“A”）.End（xlUp）.行+1
其他的
lastRow=1
如果结束
工作表（“Vorlage”）。激活
如果ActiveSheet.Range（“V”&25+j）.Value=0，则
ActiveSheet.Range（“B”和25+j&“：”和“Q”和25+j）。复制
.Range（“A”&lastRow）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlank_
：=假，转置：=假
如果结束
以
j=j+2

    既然需求已经公开，我们就有机会应用另一种方法。请记住，源范围包含多个区域这一事实可能会让我们想到一系列重复的“复制粘贴值”，这会导致不希望使用剪贴板或重复范围值
    
这一次，我们将使用数组变量获取多区域范围的值，而不是将源范围设置为对象（这仍然可以完成）
    
以后，在一个步骤中将其作为统一的连续范围输入目标范围
    
此过程使用源范围区域的值设置数组，然后使用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

    

    Sub-Range\u multiarea\u CopyValue（）
常数kRowIni，长度=25
将Wbk设置为工作簿
Dim aRngSrc（）作为变量
Dim lRowLst为长，l为长，b为字节
Rem声明对象
设置Wbk=thishworkbook
Rem将要复制的行设置为值的数组
带Wbk.表（“表2”）
l=kRowIni
对于b=1到30
如果.Range（“V”&l）.Value2=0，则
Rem调整数组大小
出错时继续下一步
重读保存aRngSrc（1+UBound（aRngSrc））
如果错误号为0，则重拨保留aRngSrc（1）
错误转到0
Rem在数组中设置行值
aRngSrc（UBound（aRngSrc））=.Cells（l，2）.调整大小（，16）.值2
Rem增加行指针
l=l+2
如果结束：下一步：以结束
Rem复位阵列结构
使用工作表功能
aRngSrc=.Transpose（.Transpose（aRngSrc））
以
目标范围内的Rem Let数组值
带Wbk表格（“表1”）
lRowLst=.Cells（.Rows.Count，1）.End（xlUp）.Row
lRowLst=IIf（.1，

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

    

    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

    

    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

    

            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

    

    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