Multi Worksheet Criteria based VBA Row Copy Coding

[cleinen1]

I have a worksheet containing itemized inventories of rooms throughout our campus with condition ratings given to each item based upon damage and so on. I'm trying to create a macro to automate the process of scanning all of these worksheets for condition values under a 3. All of my worksheets are formatted the same with the same column headings only different row counts.

My question is this, I am fairly new to VBA coding in excel, How can I have it find values below 3 in a specific column on each worksheet and copy them to a predesignated output worksheet? I have found and modified the following code to match what I'm doing so far, but I don't know how to modify it to continue through the additional sheets as this only applies to one sheet so far?

Sub MoveRowBasedOnCellValue()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Hvidsten Hall of Music - MUS").UsedRange.Rows.count
    J = Worksheets("Low Condition Report").UsedRange.Rows.count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Low Condition Report").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Hvidsten Hall of Music - MUS").Range("Q1:Q" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.count
        If CStr(xRg(K).Value) = "Yes" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Low Condition Report").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[cleinen1]

The debugger highlights that line, but changing the filter column doesn't seem to fix it.

 

[Fluff]

Which row are your headers on, and what are the first & last column in the table?

 

[cleinen1]

Header is in row 1 and the table is from A to S

 

[Fluff]

try adding the line in red.

Sub MergeData()
   Dim Mws As Worksheet
   Dim ws As Worksheet
   
   Set Mws = Sheets("Low Condition Report")
   For Each ws In Worksheets
      If Not ws Is Mws Then
         [COLOR=#ff0000]MsgBox ws.name[/COLOR]
         If ws.FilterMode Then ws.ShowAllData
         ws.ListObjects(1).Range.AutoFilter 17, "yes"
         ws.AutoFilter.Range.Offset(1).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         ws.ShowAllData
      End If
   Next ws
End Sub

When it fails check the last sheet name the message box said to make sure it's got a table

 

[cleinen1]

It's pulling the word Assumptions, which is one of the three sheets I don't want this to run on. Is there a way I can exclude these sheets by name?

 

[Fluff]

Yup, you can do that liek this

Sub MergeData()
   Dim Mws As Worksheet
   Dim ws As Worksheet
   
   Set Mws = Sheets("Low Condition Report")
   For Each ws In Worksheets
      [COLOR=#ff0000]If Not ws.name <> Mws.name And ws.name <> "Assumptions" Then[/COLOR]
         If ws.FilterMode Then ws.ShowAllData
         ws.ListObjects(1).Range.AutoFilter 17, "yes"
         ws.AutoFilter.Range.Offset(1).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         ws.ShowAllData
      End If
   Next ws
End Sub

Just add the other sheet names in the same manor

 

[cleinen1]

Ok, I was able to avoid the error messages by changing the If ws.FilterMode line to an ElseIf, but the message box is now displaying "Low Condition Report". This is the sheet that I'm trying to have results pull to. And nothing is pulling.

 

[Fluff]

Oops, forgot to remove the word Not, try

Sub MergeData()
   Dim Mws As Worksheet
   Dim ws As Worksheet
   
   Set Mws = Sheets("Low Condition Report")
   For Each ws In Worksheets
      [COLOR=#ff0000]If ws.name <> Mws.name And ws.name <> "Assumptions" Then[/COLOR]
         If ws.FilterMode Then ws.ShowAllData
         ws.ListObjects(1).Range.AutoFilter 17, "yes"
         ws.AutoFilter.Range.Offset(1).Copy Mws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         ws.ShowAllData
      End If
   Next ws
End Sub