More elegant Loop through sheets Find, Copy and paste to another Sheet

Question

I am going to try to explain this as effectively as possible, so please bear with me.

I have various sheets called "Blasted" followed by a number 1 to x.

I want to loop through Column A of each sheet "Blasted" and find various strings within the columns. Once the value has been found, it must be copied to a sheet called "Blast List".

In the Sheet "Blast List", I have a cells in Column A with the same names as the sheets (Blasted 1 and so on) going down the column.

I have done the following code and managed to get Blasted 1 working, but want to make it more elegant and need help getting it to do all sheets called "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

The idea is to ultimately look at the name of the sheet in Blast List in Column A, Select the Sheet with the same name as the text in the cell ("Blasted 1"), find the strings (e to r in the code), copy the cell, paste the cell to the next open cell in the same row as the name of the sheet in the sheet called Blast List.

Once completed, loop to the next sheet (e.g "Blasted 2") and copy and paste again.

This must be done until there is no more sheets called Blasted

Also if the string being searched for is not found, it must put "No Event" in the correct cell in Blast List.

Please help

For a start, put your search items in an array and then you can loop through that. — SJR, Oct 11 '19 at 10:42
Look at [this](https://stackoverflow.com/q/10714251/9758194) post for some ideas. — JvdV, Oct 11 '19 at 10:51

score 0 · Accepted Answer · answered Oct 14 '19 at 10:44

Hi I managed to find a way to do it using the entire weekend playing:

Heres the code I used:

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

I am going to post another question that I am looking for added on to this.

This would be in regards to if the value is not found, putting "NOTHING IN HISTORY FILE" in red in the cell.

Thanks again guys, would not have been able to find a solution without you pointing me in the right direction.

Louis · Answer 2 · 2019-10-11T12:53:03.787

-1

Here a few hints

You can store your headers in Array(), simplifying the code a lot:

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

Instead of repeating the same code define and use a Sub for copying and a Sub for pasting:

 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

And then use them on your code like this:

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

This represent a good starting point.

I hope this helps.

edited Oct 11 '19 at 12:53

answered Oct 11 '19 at 11:03

Louis

3,592
2
10
18

@ Louis: Can I do the following to specify the Array: `Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1") SItem = Srng.Value` – Hendrik Sidaway Oct 11 '19 at 11:13
@HendrikSidaway Yes, but you have to use `Application.Transpose` to make the date in `Array()` form. I'll edit the code to show you. – Louis Oct 11 '19 at 12:18
1

What's with all the .select? In almost all cases, you can do without it. There's a linked post about how to avoid it in the comments on the question. – T.J.L. Oct 11 '19 at 12:26
@HendrikSidaway I have included the code for initializing the array from your range. Hope this helps. ;) – Louis Oct 11 '19 at 13:18

More elegant Loop through sheets Find, Copy and paste to another Sheet

2 Answers2

Here a few hints