CODEWITHSUNDEEP
excelvbaloops
Geographos
Geographos

Reputation: 1466

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: enter image description here

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:

  1. 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?

enter image description here

Upvotes: 2

Views: 797

Answers (6)

José Henrique Melman
José Henrique Melman

Reputation: 21

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.

Upvotes: 0

amitklein
amitklein

Reputation: 1395

All you need to do is change

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

to

Set rg = ws1.Range("D15")

and then yopu can use rg.Value in the for loop

For i = 1 To rg.Value

Upvotes: -1

Pᴇʜ
Pᴇʜ

Reputation: 57683

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)

Upvotes: 6

Dy.Lee
Dy.Lee

Reputation: 7567

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

Upvotes: 0

Chris
Chris

Reputation: 943

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

Upvotes: 3

TourEiffel
TourEiffel

Reputation: 4424

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 ..

Upvotes: 3

Related Questions