Количество строк в зависимости от значения ячейки (l oop с копией)

Question

Я хочу синхронизировать c мой список адресов с номером, указанным в ячейке на лицевой стороне листа. Ситуация выглядит следующим образом:

В ячейке D41 у меня есть количество квартир. Теперь, когда я открываю лист «Список адресов», я хочу, чтобы первая строка была мгновенно скопирована 40 раз вниз (отмечена красным). Я знаю, что его можно описать как al oop, поэтому я попробовал этот код:

1. Первоисточник здесь:

Перемещение нескольких изображения с изменением идентификатора

 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

Здесь я получаю ошибку 424: Требуется объект

Другой код , который я пробовал это:

 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

работает, но строка копируется только один раз. Я хочу, чтобы он был скопирован 41 раз, как указано в ячейке Frontshet.D15. Как это сделать?

Answer 1

Поскольку местом назначения для вставки всегда является A3: Destination:=ws2.Range("A3") всегда вставляется в A3 (ячейка D15 раз).

Следующий код скопирует диапазон A2: K2 и вставит его в A3 и следующие D15 ячейки.

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

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

Answer 2

попробуйте это:

  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

Answer 3

Согласно Pᴇʜ ваша проблема заключается в том, что вы устанавливаете свой диапазон rg.

Скопируйте вставку и попробуйте это, это должно работать:

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

Также обратите внимание, что для второй попытки вы используете rg1.areas, а rg1 не существует, потому что вы его не установили ..

Answer 4

Время от времени я создавал упражнение по финансированию «адаптируемой» Таблицы цен, где я мог выбрать количество взносов для погашения ссуды.

Я адаптировался к вашему случаю, и я предполагаю, что вы вызываете эту функцию из событие Активировать рабочий лист на листе «Список адресов». (или вы могли бы сделать это, нажав «Alt + F11» на этом открытом листе и выбрав соответствующий вариант из меню и используя этот код:

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

Может быть, есть лучшие методы кодирования, et c, но похоже, он неплохо работает для решения предложенной задачи.

Answer 5

Все, что вам нужно сделать, это изменить

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

на

Set rg = ws1.Range("D15")

, а затем yopu может использовать rg.Value в for l oop

For i = 1 To rg.Value

Answer 6

Попробуйте,

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