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