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

标签： excelvba

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