Copy row from multiple worksheets based on array/multiple criteria

[Bomi1]

Hi!

I was wondering if I could get help on a macro that does the following:

- Checks each worksheet to see if any item's age is over 180 days.
- The inventory age is in Column H of each worksheet.
- If the item's age is over 180 days, I want to copy the entire row (from A:H) to a separate worksheet name 'Aging Inventory'

Proforma Invoice	Crate	Quantity	Description	Assigned To	Available	Serial Number	Inventory Age

<tbody>
</tbody>

 

[vcoolio]

Hello Bomi1,

The following code may get you under way:-

Sub CopyIt()

Application.ScreenUpdating = False

    Dim lRow As Long

lRow = Range("A" & Rows.Count).End(xlUp).Row

Sheets("Input").Select
    For Each cell In Range("H3:H" & lRow)
    If cell.Value >= 180 Then
    cell.EntireRow.Copy
    Sheets("Aging Inventory").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    cell.EntireRow.ClearContents
    End If
Next

Columns("A").SpecialCells(4).EntireRow.Delete
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets("Aging Inventory").Select

End Sub

The code does as you ask but also clears the "used' data from the Input sheet once it is transferred to the Aging Inventory sheet.

I've attached my sample test work book for you to peruse.

https://www.dropbox.com/s/9ldbyfsd548dflc/Bomi1.xlsm?dl=0

Good luck!

Cheerio,
vcoolio.

 

[vcoolio]

Apologies Bomi1,

I missed the "each worksheet" part of your post.

Lets try again:-

Sub CopyData()

Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim lRow As Long
    
Sheets("Aging Inventory").Range("A3:H" & Rows.Count).ClearContents

For Each ws In Worksheets
    If ws.Name = "Aging Inventory" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    
    For Each cell In Range("H2:H" & lRow)
        If cell.Value >= 180 Then
            Range(Cells(cell.Row, "A"), Cells(cell.Row, "H")).Copy
            Sheets("Aging Inventory").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next cell

NextSheet:
Next ws

Sheets("Aging Inventory").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub

Here's the updated test work book:-


https://www.dropbox.com/s/9ldbyfsd548dflc/Bomi1.xlsm?dl=0



Cheerio,
vcoolio.

 

[Bomi1]

Thank you so much for your help! It works perfectly!

 

[vcoolio]

You're welcome. Glad that I could help.

Cheerio,
vcoolio.