根据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