根据excel vba中的范围多次粘贴一行

Question

我无法解决这个问题。我正在将rowA2:C2 中的单元格从一张表复制到另一张表，但我想根据相邻columnD 上填充的单元格将它们粘贴到多个rows 中。我能够用适当的范围填充columnD。 我的问题是如何确定范围长度并多次粘贴单元格A2:C2。这是我尝试编写的代码。我之前declared 所有variables。这是我遇到问题的代码部分。谢谢你们！ Excel Sheet Here

lastrow1 = Sheets("ResourcesLib").Range("A" & Rows.Count).End(xlUp).row

For i = 1 To lastrow1
    resources = Sheets("ResourcesLib").Cells(i, "A").Value
    Sheets("sheet3").Activate
    lastrow2 = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).row

For j = 2 To lastrow2
    If Sheets("sheet3").Cells(j, "B").Value = resources Then
        Sheets("ResourcesLib").Activate
        NoCell = rsrcl.Cells(i, rsrcl.Columns.Count).End(xlToLeft).Column
        rsrcl.Range(rsrcl.Cells(i, 2), rsrcl.Cells(i,rsrcl.Cells(i,Columns.Count).End(xlToLeft).Column)).Copy
        rsrca.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Sheets("sheet3").Activate
        Sheets("sheet3").Cells(j, "A").Copy
        rsrca.Range(Cells(k, 1), Cells(m + (NoCell - 1), 1)).PasteSpecial
        Sheets("sheet3").Cells(j, "B").Copy
        rsrca.Range(Cells(k, 2), Cells(m + (NoCell - 1), 2)).PasteSpecial
        Sheets("sheet3").Cells(j, "C").Copy
        rsrca.Range(Cells(k, 3), Cells(m + (NoCell - 1), 3)).PasteSpecial
    End If

Next j
k = (NoCell - 2) + k
m = k
Application.CutCopyMode = False
Next i

Answer 1

这应该为你做。

Sub Transfer()

Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long, Lastcolumn As Long, k As Long, m As Long
Dim Firstrow As Long, Lastrow As Long, NoCell As Long
Dim activity As String, resources As String
Dim rsrcl As Worksheet, rsrca As Worksheet
Dim aRsrclRange
Dim iRangeLength
Dim lastrowtemp As Long

Set rsrcl = Sheets("ResourcesLib")
Set rsrca = Sheets("Resources")
k = 2
m = 1
NoCell = 2
iRangeLength = 1 ' default to 1 for the lines that only have a single value ... they won't be arrays

'Adding Resources to activities
lastrow1 = Sheets("ResourcesLib").Range("A" & Rows.Count).End(xlUp).row

For i = 1 To lastrow1
    resources = Sheets("ResourcesLib").Cells(i, "A").Value
    Sheets("sheet3").Activate
    lastrow2 = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).row
    For j = 2 To lastrow2
        If Sheets("sheet3").Cells(j, "B").Value = resources Then
            Sheets("ResourcesLib").Activate
            NoCell = rsrcl.Cells(i, rsrcl.Columns.Count).End(xlToLeft).Column
            rsrcl.Range(rsrcl.Cells(i, 2), rsrcl.Cells(i, rsrcl.Cells(i, Columns.Count).End(xlToLeft).Column)).Copy 'put range into clipboard for paste transpose
            aRsrclRange = rsrcl.Range(rsrcl.Cells(i, 2), rsrcl.Cells(i, rsrcl.Cells(i, Columns.Count).End(xlToLeft).Column)) 'put range into array for ubound calculation
            If IsArray(aRsrclRange) Then iRangeLength = UBound(aRsrclRange, 2) 'get the length of the range that was copied
            rsrca.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            Sheets("sheet3").Activate
            Sheets("sheet3").Range(Cells(j, "A"), Cells(j, "C")).Copy 'Copy a through c at the same time since you are pasting them in a row
            lastrowtemp = Sheets("Resources").Range("B" & Rows.Count).End(xlUp).row 'get current last row on resources
            While iRangeLength > 0 'paste on last line number of times equal to array length
                lastrowtemp = lastrowtemp + 1
                rsrca.Activate
                If IsArray(aRsrclRange) Then
                    rsrca.Range(Cells(lastrowtemp, 1), Cells(lastrowtemp, UBound(aRsrclRange, 2))).PasteSpecial
                Else
                    rsrca.Range(Cells(lastrowtemp, 1), Cells(lastrowtemp, 1)).PasteSpecial
                End If
                iRangeLength = iRangeLength - 1
            Wend
            iRangeLength = 1 'back to 1 for the lines with only 1 value
        End If
    Next j
    k = (NoCell - 2) + k
    m = k
    Application.CutCopyMode = False
Next i
End Sub