Number of rows based on the cell value (loop with copy)

问题

I would like to sync my address list with the number shown in the cell at the front sheet. The situation looks as follows:

In the cell D41 I have the number of flats. Now, when I open the "Address list" sheet I want to have the first row instantly copied 40 times down (marked with red). I know, that it can be described as a loop, this is why I tried this code:

Original source here:

Relocation of multiple images with ID changing

 Private Sub AddressList()
 Dim i As Long
 Dim rg As Range, rg2 As Range

 Dim ws1 As Worksheet, ws2 As Worksheet

 Set ws1 = ThisWorkbook.Sheets("Frontsheet")
 Set ws2 = ThisWorkbook.Sheets("Address list")

 Set rg = ws1.Range("D15").Value


 For i = 1 To rg
 Set rg2 = ws2.Range("B2:R2")
 With rg2.Offset(i - 1, 0)
    .Top = .Top
    .Left = .Left

 End With

 Next I

 End Sub

Here I am getting an error 424: Object required

Another code, which I tried is:

 Sub AddressList()
  Dim i As Long
  Dim LastrowE As Long
  Dim rng As Range
  Dim rg As Range, rg2 As Range

  Dim ws1 As Worksheet, ws2 As Worksheet

  Set ws1 = ThisWorkbook.Sheets("Frontsheet")
  Set ws2 = ThisWorkbook.Sheets("Fibre drop release sheet")

  Set rg = ws1.Range("D32")
  Set rg2 = ws2.Range("A2:k2")

  For i = 1 To rg

  With rg2.offset(i - 1, 0)
     rg2.Copy _
       Destination:=ws2.Range("A3")
  End With

  Next I

  End Sub

it works, but the row is copied only once. I want to have it copied 41 times as states in the Frontshet.D15 cell. How can I do this?

回答1:

Because your destination to paste is always A3: Destination:=ws2.Range("A3") it always pastes in A3 (cell D15 times).

The following will copy range A2:K2 and paste it into A3 and the following D15 cells.

Set rg = ws1.Range("D15")
Set rg2 = ws2.Range("A2:K2")

rg2.Copy Destination:=ws2.Range("A3").Resize(RowSize:=rg.Value)

回答2:

According to Pᴇʜ your issue is when you Set your range rg.

Please copy paste and try this, It must Work :

Private Sub AddressList()
 Dim i As Long
 Dim rg As Range, rg2 As Range

 Dim ws1 As Worksheet, ws2 As Worksheet

 Set ws1 = ThisWorkbook.Sheets("Feuil1")
 Set ws2 = ThisWorkbook.Sheets("Feuil2")

 Set rg = ws1.Range("D15")


 For i = 1 To rg
 Set rg2 = ws2.Range("B2:R2")
 With rg2.Offset(i - 1, 0)
    .Top = .Top
    .Left = .Left

 End With

 Next i

 End Sub

Also Note that for your second try you are using rg1.areas and rg1 does not exist because you didn't set it ..

回答3:

try this:

  Dim rg As Range, rg2 As Range
  Dim ws1 As Worksheet, ws2 As Worksheet

  Set ws1 = ThisWorkbook.Sheets("Frontsheet")
  Set ws2 = ThisWorkbook.Sheets("Fibre drop release sheet")

  Set rg = ws1.Range("D32")
  Set rg2 = ws2.Range("A2:k2")  'Check the correct columns

    ws2.Range("A2:K" & rg.Value + 1).Value = rg2.Value    'check the correct columns


  End Sub

回答4:

Try,

Sub test()
    Dim i As Long, j As Integer, c As Integer
    Dim LastrowE As Long
    Dim rng As Range
    Dim rg As Range, rg2 As Range
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim vResult() As Variant, vDB As Variant

    Set ws1 = ThisWorkbook.Sheets("Frontsheet")
    Set ws2 = ThisWorkbook.Sheets("Fibre drop release sheet") '<~~ Check the sheet name.

    Set rg = ws1.Range("D15") '<~~ Check the cell address.
    'Set rg2 = ws2.Range("A2:k2")
    vDB = ws2.Range("A2:k2")
    c = UBound(vDB, 2)

    ReDim vResult(1 To rg, 1 To c)
    For i = 1 To rg
        For j = 1 To c
            vResult(i, j) = vDB(1, j)
        Next j
    Next i
    ws2.Range("a3").Resize(rg, c) = vResult
End Sub

回答5:

Occasionally I was creating a "adaptable" Price Table financing exercise, where I could choose the number of instalments to repay a loan.

I adapted to your case, and I assume you are calling this function from the Activate worksheet event on "Address list" sheet. (or you could do it by pressing "Alt+F11" on that sheet open and selecting accordingly from the menu and using this code:

Private Sub Worksheet_Activate()

    lines_to_fill = Worksheets(1).Range("d15").Value
    ' this is to get values from the first sheet, instead of (1) above,
    ' it could be ("Frontsheet")

    Set firstline = Range("B2:R2")
    ' or it could be a named range, too

    ' Not sure if the number can be decreased, so deleting previous contents,
    ' just remove if not applicable.
    Range(firstline.Offset(1, 0), firstline.End(xlDown)).Delete

    ' As it is a mere repetition of the first line, why copying when you could fill?
    Range(firstline, firstline.Offset(lines_to_fill - 1, 0)).FillDown

    ' or, if you really need to iterate for some reason, comment last line
    ' and uncomment the following:
'    For i = 1 To lines_to_fill - 1
'        firstline.Copy Destination:=firstline.Offset(i, 0)
'    Next i



End Sub

Maybe there are better coding practices, etc, but it seems to work pretty well to solve the proposed task.