Question

我无法理解这个问题。我正在将row A2:C2中的单元格从一个工作表复制到另一个工作表，但我想根据相邻rows {上填充的单元格将它们粘贴到多个column中{1}}。我可以使用适当的范围填充D column。我的问题是如何确定范围长度并多次粘贴单元格D。这是我试着编写的代码。我之前A2:C2 declared。这是我遇到问题的代码的一部分。谢谢你们！ Excel Sheet Here

variables

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

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

1 个答案: