快速循环和复制

Question

我正在尝试自动复制和粘贴表“ CMJ”上某个范围（T3：AH3）中数据的复制和粘贴，该操作是通过在同一表上选择命名范围（Unique_Names）中的名称而生成的。粘贴将出现在最底部一行“ DataSheet”上的数据表中，并且仅粘贴为文本。

我对VBA几乎没有经验，并且尝试过各种代码行，到目前为止，以下代码效果最好。但是，当我运行下面的代码时，将列表中的名字复制并粘贴大约50次，并且从不遍历其余名字。

Sub LoopandCopy()

Sheets("CMJ").Select

Dim x As Range

For Each x In Sheets("CMJ").Range("Unique_Names")

    Range("T3:AH3").Copy

    Sheets("DataSheet").Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Next x


End Sub

Answer 1

未经测试，写在电话上。如果我理解正确，您想复制工作表"T3:AH3"上的范围CMJ并粘贴到工作表DataSheet上的特定行。

Sub LoopandCopy()

With thisworkbook

    Dim rangeToCopy as range
    Set rangeToCopy = .worksheets("CMJ").Range("T3:AH3")

    With .worksheets("DataSheet")

        Dim rowToPasteTo as long
        rowToPasteTo = .Range("A200").End(xlUp).Offset(1, 0).row

        .cells(rowToPasteTo, "A").resize(rangeToCopy.rows.count, rangetocopy.columns.count).value2 = rangetocopy.value2

    End with

End with

End sub

上面的方法不是复制粘贴，而是将一个范围的值分配给另一个范围（大小相同）。

Answer 2

快速循环和复制

我在这里猜测唯一值在一栏中。

将其放入CMJ工作表代码：

Option Explicit

Private TargetValue As Variant

Sub LoopandCopy()

  Const cSource As Variant = "CMJ"              ' Source Worksheet Name/Index
  Const cTarget As Variant = "DataSheet"        ' Target Worksheet Name/Index
  Const cStrUnique As String = "Unique_Names"   ' Named Range
  Const cStrSource As String = "T3:AH3"         ' Source Range
  Const cTargetColumn As Variant = "A"          ' Column Letter/Number

  Dim i As Long             ' Named Range Cells Counter
  Dim lngLastRow As Long    ' Target Last Row
  Dim vntSource As Variant  ' Source Array

  ' Calculate Target Last Row.
  lngLastRow = Worksheets(cTarget).Cells(Rows.Count, cTargetColumn) _
      .End(xlUp).Row

  With Worksheets(cSource)

    ' Paste Source Range into Source Array.
    vntSource = .Range(cStrSource)

    For i = 1 To .Range(cStrUnique).Cells.Count
      ' Resize the cell at the intersection of Target Last Row and
      ' Target Column by the size of Source Array.
      Worksheets(cTarget).Cells(lngLastRow + i, cTargetColumn) _
          .Resize(, UBound(vntSource, 2)) = vntSource
    Next

  End With

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Cells.Count = 1 Then
    If Not Intersect(Worksheets("CMJ").Range("N7"), Target) Is Nothing Then
      If Target.Value <> TargetValue Then LoopandCopy
      TargetValue = Target.Value
    End If
  End If
End Sub

遍历命名范围以复制和粘贴数据

2 个答案:

快速循环和复制