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

VBA：从表复制并粘贴到创建列表

1 个答案: