VBA - Macro to find specific text in column and copy certain cells in continous rows to different sheet

[WendelaS]

Dear all,

I am relatively new to VBA and Macros.

Basically, I am trying to build a database of sorts in which I have 600+ hotel rooms, for each room one sheet. In each sheet I will track the current problems where different departments need to come in and repair these.

Therefore, I want an overview sheet in which all entries are listed that are "ongoing".
This means that all 600+ sheets need to look for entries that have the status "ongoing" in Column E, and then copy these rows to the sheet "overview", obviously underneath eachother.
A: Kamernummer
B: What?
C: Department
D: Action
E: Status
F: Description
G: Date entered
Every time I run the macros, I also want to have it delete the overview, so the entries that may have been completed in the meanwhile, will disappear.

I have found bits and pieces here (such as https://www.mrexcel.com/forum/excel...y-certain-cells-same-row-different-sheet.html and https://www.mrexcel.com/forum/excel...-copy-rows-based-criteria-new-sheet-file.html and https://www.mrexcel.com/forum/excel...ch-multiple-sheets-display-results-sheet.html, but am completely stuck.

What I have so far, from copying bits and pieces, and deleting bits of pieces is this:
But I do feel like I have created now a huge mess that does not belong together.

Option ExplicitPrivate Sub Main()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim strTMP As String
    On Error GoTo Fin
    Application.DisplayAlerts = False
   
    For Each wksSheet In ThisWorkbook.Worksheets
    'strFound = "Laptops"
        If wksSheet.Name <> wksSheetNew.Name Then
            Set rngRange = wksSheet.Columns(2).Find(What:=strFound, _
                LookIn:=xlValues, LookAt:=xlPart)
            If rngRange Is Nothing Then
            Else
                strLink = rngRange.Value
            End If
            If Not rngRange Is Nothing Then
                strTMP = rngRange.Address
                Do
                    lngLastRow = lngLastRow + 1
                    wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy _
                        Destination:=wksSheet(2).Cells(lngLastRow, 1)
                    Set rngRange = wksSheet.Columns(5).FindNext(rngRange)
                Loop While rngRange.Address <> strTMP
                wksSheetNew.Cells.EntireColumn.AutoFit
            End If
        End If


Next wksSheet


Fin:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    If strTMP = "" Then
        MsgBox "Search term was not found!"
    Else
        MsgBox "All matching data has been copied."
    End If
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub

Is somebody out there that would be able to help me in any way?
Thank you all a lot in advance!!!

 

[My Aswer Is This]

Assuming you already have a sheet named "overview"
And your looking for the value "ongoing" in column "E" of all sheets in your workbook.
If this is not what your wanting please explain.
Try this:

Sub Copy_To_Overview()
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Sheets("overview").Cells.Clear
Lastrow = Sheets("overview").Cells(Rows.Count, "A").End(xlUp).Row

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "overview" Then
            Lastrowa = Sheets(i).Cells(Rows.Count, "E").End(xlUp).Row
            For b = 1 To Lastrowa
                If Sheets(i).Cells(b, "E").Value = "ongoing" Then
                    Sheets(i).Rows(b).Copy Sheets("overview").Rows(Lastrow)
                    Lastrow = Lastrow + 1
                End If
            Next
        End If
    Next
Application.ScreenUpdating = True
MsgBox "Finished"
End Sub

 

[My Aswer Is This]

Assuming you already have a sheet named "overview"
And your looking for the value "ongoing" in column "E" of all sheets in your workbook.
If this is not what your wanting please explain.
Try this:
This is a filter script which may run faster:

Sub Auto_Filter_My_Data()
Application.ScreenUpdating = False
Sheets("overview").Cells.Clear
    Dim b As Long
    b = Sheets.Count
    
    For i = 1 To b
        
    If Sheets(i).Name <> "overview" Then
        With Worksheets(i).Range("E1").CurrentRegion
            Lastrow = Sheets("overview").Cells(Rows.Count, "A").End(xlUp).Row + 1
            .AutoFilter
            .AutoFilter Field:=5, Criteria1:="ongoing"
            .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Worksheets("overview").Range("A" & Lastrow)
        End With
        Sheets(i).AutoFilterMode = False
    End If
    Next
Application.ScreenUpdating = True
End Sub

 

[WendelaS]

Hi!

Oh wow, thank you so much for your answer!

This seems to be totally what I need, just with the problem that it doesn't work unfortunately.
I definitely have two sheets in which the status of some issues is ongoing, but they are not copied into the overview sheet, it stays empty.
Any idea why that could be the case?

Thank you again!

 

[My Aswer Is This]

It does not help much when you just say it does not work.
Have you ever run scripts before?
What happened when you tried the script?
Which of the two scripts did you try?

The script looks for "ongoing" in column "E" are you sure it's "ongoing" and not "Ongoing"

And you have headers in row(1)
I test all my scripts.

 

[WendelaS]

You are totally right, I made the mistake of ongoing vs Ongoing, my bad, thought I changed it earlier.
It is actually working perfectly.

Last question, would it be possible to keep my header in the overview tab as well, so start the inserts from row 2 onwards? (So I can filter them easily lateron).

Thank you in advance again! You've been extremely helpful!

 

[WendelaS]

I have figured it out, thank you anyways!