Excel 更优雅的工作表循环查找、复制并粘贴到其他工作表

我将尽可能有效地解释这一点，所以请耐心听我说

我有各种各样的表格叫做“爆炸”，后面是数字1到x

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

在工作表“爆炸列表”中，a列中有一个单元格，其名称与下一列的工作表（爆炸1等）相同

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

Sub-CopyBlastSheetData（）
像线一样变暗
将g作为字符串
调暗h为字符串
我像绳子一样暗
作为字符串的Dim j
调暗k为字符串
把l调成线
把m调成线
将n变暗为字符串
调暗为弦
调暗p为字符串
Dim q As字符串
调暗r为字符串
他和我一样长
暗CStep尽可能长
Dim xCount为整数
将ws设置为工作表
将ws1设置为工作表
e=“PU”
g=“线路测试”
h=“额外数据”
i=“间歇性连接检测”
j=“缺少数据”
k=“故障检测”
l=“不连贯的数据”
m=“延迟错误检测”
n=“费用”
o=“其他缺失数据”
p=“低能量检测”
q=“附加非相干DET”
r=“火灾”
CStep=1
对于s=1到ActiveWorkbook.Sheets.Count
如果仪表（1，图纸名称，“爆破”）>0，则xCount=xCount+1
下一个
而CStepSub 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

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

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