更优雅的循环工作表查找、复制和粘贴到另一个工作表

Posted 2023-03-27

技术标签:

【中文标题】更优雅的循环工作表查找、复制和粘贴到另一个工作表【英文标题】：More elegant Loop through sheets Find, Copy and paste to another Sheet 【发布时间】：2020-02-08 20:49:36 【问题描述】：

我将尽可能有效地解释这一点，所以请多多包涵。

我有各种名为“Blasted”的工作表，后跟数字 1 到 x。

我想遍历每张“Blasted”的 A 列，并在列中找到各种字符串。找到值后，必须将其复制到名为“Blast List”的工作表中。

在工作表“Blast List”中，我在 A 列中有一个单元格，其名称与沿该列向下的工作表（Blasted 1 等）相同。

我已经完成了以下代码并设法让 Blasted 1 工作，但想要让它更优雅，需要帮助让它完成所有名为“Blasted”的工作表

Sub CopyBlastSheetData()

    Dim e As String
    Dim g As String
    Dim h As String
    Dim i As String
    Dim j As String
    Dim k As String
    Dim l As String
    Dim m As String
    Dim n As String
    Dim o As String
    Dim p As String
    Dim q As String
    Dim r As String
    Dim s As Long
    Dim CStep As Long
    Dim xCount As Integer
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    e = "PU"
    g = "LINE TEST"
    h = "EXTRA DETS"
    i = "INTERMITTENT CONNECTION DETS"
    j = "MISSING DETS"
    k = "OUT OF ORDER DETS"
    l = "INCOHERENT DETS"
    m = "DELAY ERRORS DETS"
    n = "CHARGE"
    o = "ADDITIONAL MISSING DETS"
    p = "LOW ENERGY DETS"
    q = "ADDITIONAL INCOHERENT DETS"
    r = "FIRE"

    CStep = 1

        For s = 1 To ActiveWorkbook.Sheets.Count
            If InStr(1, Sheets(s).Name, "Blasted") > 0 Then xCount = xCount + 1
        Next

    While CStep < xCount

    Do

    Set ws = ThisWorkbook.Worksheets(CStr("Blasted " & CStep))
    Set ws1 = ThisWorkbook.Worksheets("Blast List")


    ws.Select
    Range("A1").Select
            Cells.Find(What:=e, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("E3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=g, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("G3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=h, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("H3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=i, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("I3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=j, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("J3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=k, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("K3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        ws.Select
    Range("A1").Select
            Cells.Find(What:=l, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("L3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=m, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("M3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=n, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("N3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=o, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("O3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=p, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("P3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=q, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("Q3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ws.Select
    Range("A1").Select
            Cells.Find(What:=r, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy

    ws1.Select
    Range("R3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    Wend

    CStep = CStep + 1

    Next

End Sub

思路是最终在A列的Blast List中查看sheet的名称，选择与单元格中的文本同名的Sheet（“Blasted 1”），找到字符串（e to r in代码），复制单元格，将单元格粘贴到与名为 Blast List 的工作表中工作表名称相同的行中的下一个打开的单元格。

完成后，循环到下一张表（例如“Blasted 2”）并再次复制和粘贴。

必须在没有更多称为 Blasted 的工作表之前完成此操作

此外，如果没有找到要搜索的字符串，则必须将“No Event”放在 Blast List 的正确单元格中。

请帮忙

【问题讨论】：

首先，将您的搜索项放在一个数组中，然后您可以循环遍历它。查看this 的帖子以获取一些想法。 【参考方案1】：

您好，我设法利用整个周末的比赛找到了一种方法：

这是我使用的代码：

Sub CopySingle()

    Dim wsfr As Worksheet
    Dim wsl As Worksheet
    Dim BlNumber As String
    Dim BSStep As Long

    Dim SI As String
    Dim Srng As Range
    Dim Nrng As Range

    Dim Rrng As Range
    Dim Brng As Range

    Dim Arng As Range

    Application.ScreenUpdating = False

    BSStep = 1

    Set Rrng = ThisWorkbook.Worksheets("Blast List").Range("A3", Range("A3").End(xlDown))

    Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1")

    For Each Brng In Rrng.Cells

        For Each Nrng In Srng.Cells

        On Error Resume Next

        SI = Nrng.Value

        BlNumber = CStr("Blasted " & BSStep)

        Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
        Set wsl = ThisWorkbook.Worksheets("Blast List")

        wsfr.Select
            Range("A1").Select
                Cells.Find(What:=SI, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
                Selection.Copy

        Sheets("Blast List").Select
            Range("A1").Select
                Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select

                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False

        Next Nrng

        BSStep = BSStep + 1

    Next Brng

Application.ScreenUpdating = True

End Sub

我将发布另一个我正在寻找的问题。

如果没有找到该值，则在单元格中将“NOTHING IN HISTORY FILE”以红色显示。

再次感谢大家，如果没有您指出正确的方向，将无法找到解决方案。

【讨论】：

【参考方案2】：

这里有一些提示

您可以将标题存储在Array() 中，大大简化了代码：

Function rangeToArray(rng As Range) As Variant
     rangeToArray = Application.Transpose(Application.Transpose(rng))
End Function

Sub CopyBlastSheetData()
    headers = rangeToArray(ThisWorkbook.Worksheets("Blast List").Range("E1:Q1"))
    'Rest of the code [..]
End Sub

不要重复相同的代码，而是定义并使用 Sub 进行复制和使用 Sub 进行粘贴：

 Sub copyFrom(ws As Worksheet, rng As Range, search As String)
    ws.Select
    rng.Select
    Cells.Find(What:=search, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.Copy
End Sub

Sub PasteTo(ws As Worksheet, rng As Range)
    ws.Select
    rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
End Sub

然后像这样在你的代码中使用它们：

Call copyFrom(ws, Range("A1"), headers(1))
Call PasteTo(ws, Range("E3"))

这是一个很好的起点。

我希望这会有所帮助。

【讨论】：

@Louis：我可以执行以下操作来指定数组：Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1") SItem = Srng.Value @HendrikSidaway 是的，但您必须使用Application.Transpose 以Array() 形式填写日期。我会编辑代码给你看。所有 .select 是怎么回事？在几乎所有情况下，您都可以不用它。在问题的 cmets 中有一个关于如何避免它的链接帖子。 @HendrikSidaway 我已经包含了用于从您的范围初始化数组的代码。希望这可以帮助。 ;)

以上是关于更优雅的循环工作表查找、复制和粘贴到另一个工作表的主要内容，如果未能解决你的问题，请参考以下文章

用于将行复制并粘贴到另一个工作表而不将其粘贴到页面数英里的宏

在同一活动工作簿中从一个工作表复制和粘贴到另一个工作表时出现错误 1004

根据标准复制并粘贴到另一个工作表

Excel VBA在循环内复制和粘贴循环

复制并粘贴到另一个工作表的第一个空行，如果第一个单元格为空，则粘贴到上一行

VBA：如果工作簿中的工作表名称等于从用户窗体中选择的组合框值，则复制该工作表并将其粘贴到另一个工作簿中