Excel VBA自动复制行

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

我有一个选项卡（销售）与一个WEB API查询导入数据在此表中每5分钟。 我在销售表中有一行标识每个项目的名称范围。 该行有100个不同的名称，在工作簿中有100个使用相同名称创build的工作表。

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

这是发射副本：

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

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

Answer 1

没有进一步的信息，这里是我在评论中所描述的纲要。 这里命名区间的列表从NamesSheet单元格J3开始。 在图像中，我已经显示在同一张表格（为简单起见， SourceSheet ）。 该列表被读入一个数组，并且该数组被循环select适当的表来设置值。

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

目前没有为缺less的表单添加error handling。

我没有假设表格中会有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个命名范围，已经在工作簿范围内进行了testing，并且您将忽略其中一个称为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