Excel VBA自动复制行

Question

我需要帮助来创建一种将行复制到特定工作表的自动方法。

我有一个带有 WEB api 查询的选项卡（销售），每 5 分钟在此表中导入数据。我在销售表中有一行，其中包含标识每个项目的名称范围。该行有 100 个不同的名称，并且在工作簿中创建了 100 个具有相同名称的工作表。

我想复制每个项目的整行，并将其复制到与项目名称相同的工作表中。

这是为了触发复制子：

'Copy Sales data Every 10 Min
Sub test()
    'Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure…"
End Sub

我已经看到了很多关于如何自动复制行的方法，但是我在复制行和使用项目名称并粘贴到具有相同名称的其他工作表方面需要帮助。

Answer 1

如果没有更多信息，这里是我在 cmets 中描述的概要。这里命名范围的列表从NamesSheet 中的单元格J3 开始。在图像中，我在同一张纸上展示了它（为简单起见，SourceSheet）。该列表被读入一个数组，并且该数组被循环以选择适当的工作表来设置值。

而不是复制和粘贴，它在数组索引访问的工作表中设置目标行（下一个可用行）等于源行（copyRow）。 With 语句用于避免选择目标工作表（更有效）。

目前没有为丢失的工作表添加错误处理。

我没有假设工作表中会有 100 个命名范围的列表，否则您可以从一开始就调整数组的大小。

销售标签的 ColA 中的命名范围：

名称表中的命名范围列表（缩写）

Option Explicit

Private Sub myProc()

Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsNames As Worksheet

Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sales")
Set wsNames = wb.Worksheets("Names")

Dim namesArr()
namesArr = wsNames.Range("J3:J" & wsNames.Cells(wsNames.Rows.Count, "J").End(xlUp).Row).Value

If UBound(namesArr, 1) <> wsSource.Range("ITEMName").Rows.Count Then
    MsgBox "There are not a matching number of named ranges listed in Names sheet."
    Exit Sub
End If

Dim i As Long
Dim currLastRow As Long
'Any optimization code could actually go in outer calling sub but consider
'some such as the following

Application.ScreenUpdating = False
Dim copyRow As Range

For i = LBound(namesArr, 1) To UBound(namesArr, 1)

   With wb.Worksheets(namesArr(i, 1))

     Set copyRow = wsSource.Range(namesArr(i, 1)).EntireRow

     If IsEmpty(.Range("A1")) Then   'First row in sheet is available

         .Rows(1).Value = copyRow.Value2

     Else

         currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

         .Rows(currLastRow + 1).Value = copyRow.Value2

     End If

   End With

Next i

Application.ScreenUpdating = True

End Sub

版本 2：

在Sales 工作表中循环命名范围（假设工作表中只有 101 个命名范围，在工作簿范围内进行了测试，并且您将忽略其中一个称为 ITEMName 的命名范围，在不同的工作表中不需要列表。方法改编自@user1274820。

Option Explicit

Private Sub myProc2()

    Dim wb As Workbook
    Dim wsSource As Worksheet

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Sales")

    Dim currLastRow As Long
    'Any optimization code could actually go in outer calling sub but consider
    'some such as the following

    Application.ScreenUpdating = False

    Dim copyRow As Range
    Dim nm As Variant

    For Each nm In ThisWorkbook.Names

        If nm.RefersToRange.Parent.Name = "Sales" And nm.Name <> "ITEMName" Then

            With wb.Worksheets(nm.Name)

                Set copyRow = wsSource.Range(nm.Name).EntireRow

                If IsEmpty(.Range("A1")) Then    'First row in sheet is available

                    .Rows(1).Value = copyRow.Value2

                Else

                    currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

                    .Rows(currLastRow + 1).Value = copyRow.Value2

                End If

            End With

        End If

    Next nm

    Application.ScreenUpdating = True

End Sub