Более элегантный цикл по листам Поиск, копирование и вставка на другой лист - PullRequest
Новая
       3

Более элегантный цикл по листам Поиск, копирование и вставка на другой лист

1 голос
/ 11 октября 2019

Я попытаюсь объяснить это как можно более эффективно, поэтому, пожалуйста, потерпите меня.

У меня есть различные листы, называемые «Взрыв», за которыми следуют цифры от 1 до x.

Я хочу пройтись по столбцу A каждого листа «Blasted» и найти различные строки в столбцах. Как только значение найдено, оно должно быть скопировано на лист с именем «Blast List».

В листе «Blast List» у меня есть ячейка в столбце A с такими же именами, что и у листов (Blasted1 и т. Д.), Спускаясь вниз по столбцу.

Я выполнил следующий код и сумел заставить работать 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

Идея состоит в том, чтобы в конечном итоге посмотреть на имя листа в Blast List в столбце A, выбрать лист с тем же именем, что и текст в ячейке («Blasted 1»), найтистроки (от e до r в коде), скопируйте ячейку, вставьте ячейку в следующую открытую ячейку в той же строке, что и имя листа в списке с именем Blast List.

По завершении выполните цикл доследующий лист (например, «Blasted 2») и скопируйте и вставьте снова.

Это необходимо сделать до тех пор, пока не останется больше листов с именем Blasted

Также, если искомая строка не найдена, это должно поставить "Нет событий" в тОн исправил ячейку в Blast List.

Пожалуйста, помогите

Ответы [ 2 ]

0 голосов
/ 14 октября 2019

Привет, мне удалось найти способ сделать это, используя все выходные, играя:

Вот код, который я использовал: 

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

Я собираюсь опубликовать еще один вопрос, который яищите добавленный к этому.

Это было бы в отношении того, если значение не найдено, помещая "НИЧЕГО В ИСТОРИЧЕСКОМ ФАЙЛЕ" красным цветом в ячейку. не смог найти решение, если бы вы не указали мне правильное направление.

0 голосов
/ 11 октября 2019

Вот несколько подсказок

  • Вы можете хранить свои заголовки в 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"))

Это хорошая отправная точка.

Надеюсь, это поможет.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...