Question

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

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

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

在工作表“爆炸列表”中，我在A列中有一个单元格，其名称与该列中的工作表名称相同（被爆炸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列的“爆炸列表”中查看工作表的名称，选择与单元格中的文本名称相同的工作表（“ Blasted 1”），找到字符串（其中的e到r代码），复制该单元格，将其粘贴到与工作表中名为“爆炸列表”的工作表名称相同的行中的下一个打开的单元格中。

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

必须这样做，直到没有被称为“爆破”的纸张为止

如果找不到要搜索的字符串，则必须在“爆炸列表”的正确单元格中放置“无事件”。

请帮助

Answer 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”（NOTHING IN HISTORY FILE）以红色显示在单元格中。

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

Answer 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"))

这是一个很好的起点。

我希望这会有所帮助。

更加优雅地遍历工作表查找，复制和粘贴到另一个工作表

2 个答案:

这里有一些提示