循环工作表并粘贴代码答案

【问题标题】：Loop through worksheets and paste code循环工作表并粘贴代码
【发布时间】：2016-05-07 08:46:12
【问题描述】：

嗨，我有代码是为了

遍历所有以“673”开头的工作表
从第 5 行开始复制所有包含数据的行
将条目粘贴到“颜色”工作表的下一个空行中

我遇到以下问题：

代码仅在活动的工作表中运行
不循环遍历所有工作表

当它粘贴到“颜色”工作表中时，它会直接粘贴到第 2 行的标题上。第一个空白行是第 3 行以后，我希望逻辑粘贴到下一个可用的空白行，因为它循环通过床单。

Sub Consolidate()

Dim lastrow As Long
Dim report As Worksheet
Set report = Excel.ActiveSheet

For Each Sheet In ActiveWorkbook.Worksheets
    If InStr(Sheet.Name, "673") > 0 Then      

        With report
            .Range(.Cells(5, "K"), .Cells(.Rows.Count, "K").End
            (xlUp)).EntireRow.Copy
        End With

        Worksheets("Colours").Select

        lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row

        Worksheets("Colours").Cells(lastrow + 1, 1).Select
        ActiveSheet.Paste  

    End If
Next
End Sub

非常感谢您的帮助。

【问题讨论】：

With report 应该是 With sheet。试试这个

标签： vba excel

【解决方案1】：

KS 是对的，要让您的代码正常运行，您只需要参考工作表即可。我已经开始进一步修改它，所以我将发布我所做的全部：

首先，我删除了不需要的“Set report =”行（或者，您可以在循环开始时使用“Set report”，但正如 KS 所说，直接使用“With Sheet”更容易）。

CHANGED1 = 你说它应该循环遍历以 673 开头的工作表，因此这一新行检查与 673 匹配的前三个字符，而不是仅仅查看 673 是否出现在工作表名称中的任何位置。

NEW = 激活工作表，这使得下一个复制命令起作用。

CHANGED2 = 使用工作表，如上所述。

CHANGED3 = 您说它应该从第 5 行开始复制包含数据的行（之前您的代码会复制第 1-5 行）。

Sub Consolidate()
    Dim lastrow As Long
    Dim report As Worksheet

    For Each Sheet In ActiveWorkbook.Worksheets
        If Left(Sheet.Name, 3) = "673" Then 'CHANGED1

            Worksheets(Sheet.Name).Select 'NEW

            With Sheet 'CHANGED2
                .Range("A5", Range("A" & 65536).End(xlUp)).EntireRow.Copy 'CHANGED3
            End With

            Worksheets("Colours").Select

            lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row

            Worksheets("Colours").Cells(lastrow + 1, 1).Select
            ActiveSheet.Paste

        End If
    Next
End Sub

希望这会有所帮助！

【讨论】：

【解决方案2】：

试试下面的代码

Sub Consolidate()    
Dim sheet As Worksheet, coloursSheet As Worksheet

Set coloursSheet = ActiveWorkbook.Worksheets("Colours")

For Each sheet In ActiveWorkbook.Worksheets
    If Left(sheet.Name, 3) = "673" Then
        sheet.Range("K5:K" & sheet.Cells(sheet.Rows.Count, "K").End(xlUp).Row).SpecialCells(xlCellTypeConstants).EntireRow.Copy _
        Destination:=coloursSheet.Cells(coloursSheet.Rows.Count, "A").End(xlUp).Offset(1)
    End If
Next
End Sub

它：

避免无用的选择和变量
仅复制非空白单元格（假设数据是“常量”，即不是公式）

【讨论】：