Vba 在行上循环并将值复制到外部文件（按单元格值索引的工作表）

我是VBA的新手，对于这个基本问题我很抱歉。我需要创建一个循环，在每个迭代中脚本：

将

Wb1

的O6:AA6复制到同一工作簿的O1:AA1中

将列B:E复制到

Wb1

的

N6

中名为“DGP1”的表中的

Wb2

重复上述两个步骤：将O7:AA7复制到O1:AA1，将B:E复制到

Wb2

（图纸名称由

Wb1

的

N7

中包含的值给出，如“DGP2”）

我编写的代码虽然没有实现循环，也没有引用

N6、N7

中的值，但至少执行了我需要的计算。定义了两个工作簿后，它包括：

Wb1.Activate
    Range("O6:AA6").copy
    Range("O1:AA1").PasteSpecial
    Columns("B:E").copy
Wb2.Activate
    Sheets("DGP1").Select
    Selection.PasteSpecial Paste:=xlPasteValues

Wb1.Activate
    Range("O7:AA7").copy
    Range("O1:AA1").PasteSpecial
    Columns("B:E").copy
Wb2.Activate
    Sheets("DGP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues

实际上，我有更多的行要复制粘贴，我需要通过

N6、N7、…

中的条目引用最终的工作表名称

谢谢你的建议

---

斯特凡诺

这是一个好的开始；下面是一些编写宏的技巧，这些技巧将帮助您开始工作，但也会改进您的代码

范围-大多数情况下，设置 “目的地”范围等于“起点”范围（如果范围为 相同的。因此，与其这样做

Range("O6:AA6").copy
Range("O1:AA1").PasteSpecial

你可以做

Range("O1:AA1") = Range("O6:AA6").Value

Wb1.Sheets("Sheet1").Range("O1:AA1") = Wb1.Range("O6:AA6").Value
Wb2.Sheets("DGP1").Columns("B:E") = Wb1.Sheets("Sheet1").Columns("B:E").Value

选择-您几乎不需要“选择”单元格和工作表（除非您愿意） 宏运行完毕后要选择的单元格/工作表）。 最好直接参考表格。相反，还是这样 的

假设您的数据在

Wb1

的第1页上，您可以

Range("O1:AA1") = Range("O6:AA6").Value

Wb1.Sheets("Sheet1").Range("O1:AA1") = Wb1.Range("O6:AA6").Value
Wb2.Sheets("DGP1").Columns("B:E") = Wb1.Sheets("Sheet1").Columns("B:E").Value

For Loop-要使用

For

循环，可以设置变量并建立范围 给定递增变量的字符串。例如，您可以设置 变量

x

等于6，并增加所需的次数 （假设5到10次）

范围/工作表引用-如果单元格中的值是有效范围和/或工作表的名称，则可以轻松使用它们构建 参考该范围/表。例如

Wb1.Sheets（“Sheet1”）。范围（“N6”）。值等于“DPG1”，即
Wb1
的
sheet 1
上的
N6
中的值。再加上
循环，则最终代码如下所示

    for x = 6 to 10
        Wb1.Sheets("Sheet1").Range("O1:AA1") = _
              Wb1.Range("O" & x & ":AA" & x).Value
        Wb2.Sheets(Wb1.Sheets("Sheet1").Range("N" & x).Value).Columns("B:E") = _
              Wb1.Sheets("Sheet1").Columns("B:E").Value
    next x

现在已经完成了，您应该知道每次（O1）都要将不同的值O6、O7等粘贴到相同的位置。我假设这不是您想要的，但是您现在也有了一些工具来更新该部分

希望这有帮助……

尝试一下（您需要重命名工作簿名称和工作表名称）：

---

伟大的非常感谢，这非常清楚地涵盖了整个问题。就效率而言，Stefanoj只是一个好奇心。正如您正确地说的，通常在每次Excel操作时激活工作表不是一个好主意。然而，在我以前的代码（没有循环）中，10个DGP的复制粘贴操作花费了大约2秒，现在几乎是13秒。你认为这和工作表激活有关吗？（对我来说答案是“否”，但正如我所说，我对VBA了解不多。）也可能是因为您正在更新整列数据，即

Wb1.Sheets（“Sheet1”）。columns（“B:e”）。Value

。根据您拥有的excel版本，更新的行数可能至少为65536行*4列（excel 2007及更高版本的更多），需要更新的单元格数量很多。最好选择有限的单元格区域，例如

Wb1.Sheets（“Sheet1”）。范围（“B1:E5000”）。值

Sub SO_19646599()
    Dim oWB1 As Workbook, oWB2 As Workbook
    Dim oWS1 As Worksheet, oWS2 As Worksheet
    Dim oRngRef As Range, oRng1 As Range, oRng2 As Range
    Dim sTmp As String, iOffset As Long, iErr As Long, sErr As String

    ' Source Workbook and Worksheet (assumed already open)
    Set oWB1 = Workbooks("Wb1")
    Set oWS1 = oWB1.Worksheets("Sheet1") ' Assuming Sheet1
    ' Target Workbook (assumed already open)
    Set oWB2 = Workbooks("Wb2")
    ' Reference range to start
    Set oRngRef = oWS1.Range("N6")
    ' Offset counter
    iOffset = 0
    ' Loop until oRngRef is an empty cell
    Do Until IsEmpty(oRngRef)
        ' Copy O6:AA6 to O1:AA1 in Wb1 (assuming Sheet1), with row offset
        Set oRng1 = oWS1.Range("O6:AA6").Offset(iOffset, 0)
        Set oRng2 = oWS1.Range("O1:AA1").Offset(iOffset, 0)
        oRng1.Copy Destination:=oRng2
        ' Get reference to Worksheet in Wb2 by the value contained in N6 of Wb1 (assumed Sheet1), with row offset
        sTmp = oRngRef.Value
        Set oWS2 = oWB2.Worksheets(sTmp)
        If oWS2 Is Nothing Then
            iErr = iErr + 1
            sErr = sErr & iErr & vbTab & "No such """ & sTmp & """ worksheet (" & oRngRef.Address & ") in " & oWB2.Name & vbCrLf
        Else
            ' copies the columns B:E from Wb1 (Sheet1) to Wb2 (Sheet name as N6)
            oWS1.Columns("B:E").Copy Destination:=oWS2.Columns("B:E")
        End If
        iOffset = iOffset + 1
        ' Update Reference range
        Set oRngRef = oWS1.Range("N6").Offset(iOffset, 0)
    Loop
    If iErr > 0 Then
        Debug.Print sErr
        MsgBox iErr & " errors occurred, please review Immediate window." & vbCrLf & vbCrLf & sErr
    End If
    ' Cleanup
    Set oWS2 = Nothing
    Set oWB2 = Nothing
    Set oWS1 = Nothing
    Set oWB1 = Nothing
End Sub