VBA: копирование из таблицы и вставка в список создания

Question

Новое в VBA

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

Sub tblcopypast()

Dim Month As String
Dim tbl As ListObject
Dim i As Integer
Dim lastrow As Integer

Set tbl = ActiveSheet.ListObjects("Table1")
Month = ActiveSheet.Range("E1").Value
lastrow = tbl.ListRows.Count

For i = 1 To lastrow
    If tbl.DataBodyRange(i, 2) = Month Then
    tbl.ListRows(i).Range.Copy
    ActiveSheet.Range("rng").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    End If
Next

End Sub

Answer 1

Ваш ActiveSheet.Range("rng").End(xlUp).Offset(1, 0).PasteSpecial довольно сложно.Особенно в петле.Попробуйте следующий код:

Option Explicit

Sub tblcopypast()

Dim Month As String
Dim tbl As ListObject
Dim iCt As Integer
Dim jCt As Integer
Dim lastrow As Integer
Dim targetRange As Range
Dim actRange As Range

    Set tbl = ActiveSheet.ListObjects("Table1")
    Month = ActiveSheet.Range("E1").Value
    lastrow = tbl.ListRows.Count
    jCt = 0
    Set actRange = ActiveCell

    Set targetRange = ActiveSheet.Range("rng").End(xlUp).Offset(1, 0)

    For iCt = 1 To lastrow
        If tbl.DataBodyRange(iCt, 2) = Month Then
            tbl.ListRows(iCt).Range.Copy
            targetRange.Offset(jCt, 0).PasteSpecial xlPasteValues
            jCt = jCt + 1
        End If
    Next
    actRange.Select
End Sub

Sub DefineSamples()
'sample data I used to review your code!
Dim cell As Range
    Range("M1") = "F1"
    Range("N1") = "F2"
    Range("O1") = "F3"
    Range("P1") = "F4"

    For Each cell In Range("M2:P12")
        cell.Value = Int(Rnd() * 100)
    Next cell

    Range("E1").Value = "Jan"

    Range("N3").Value = "Jan"
    Range("N5").Value = "Jan"
    Range("N7").Value = "Jan"
    Range("N9").Value = "Jan"
    Range("N10").Value = "Jan"
    Range("N11").Value = "Jan"

    On Error Resume Next
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$M$1:$P$12"), , xlYes).Name = "Table1"
    On Error GoTo 0
    Range("Table1").HorizontalAlignment = xlCenter
End Sub