How to Macro to copy rows from multiple worksheets based on a cell value greater than zero

How to us a Macro to copy rows from multiple worksheets based on a cell value greater than zero

Requirement:

The user has a workbook (Master BOM) that has eight (8) worksheets: Project Info, Metals, Pathway, Copper, Fiber. Backbone, Raceway, Miscellaneous

The Project Info Sheet has User input information Cells B4-6, B9-11 and B12.

The other seven sheets are material parts lists and the user will only enter quantities in cells A4 thru A600. Not all cells will have quantities some will be left blank or have a "0".

The user is trying to accomplish is to have a macro that will create a new separate Worksheet named " Current BOM" that will add the User Input info from the "Project Info" Worksheet and then will scan the A4 thru A600 cells of the other seven worksheets and copy only the rows that have a value great that "0" into the "Current BOM" worksheet starting at Cell B9.

I would like to have a separate macro that the user can use to clear all of the values from cells A4 thru A600 of the seven worksheets.

I have attached the "Master BOM" workbook and a sample of what the "Current BOM" should look like.

Solution:

Code:

Sub ExportBOM()
    Dim v, a, r As Range, rr As Range, ws As Worksheet, i As Integer
    Dim n As Integer
    
    Set ws = Worksheets("Current BOM")
    
    'Rename worksheet "Fiber " to "Fiber"
    a = Split("Metals,Pathway,Copper,Fiber,Backbone,Raceway,Miscellaneous", ",")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    For Each v In a
        With Worksheets(v)
            .UsedRange.AutoFilter 1, ">0"
            Set r = Intersect(.Rows("4:" & .Rows.Count), .UsedRange).SpecialCells(xlCellTypeVisible)
            If r Is Nothing Then GoTo NextV
            Set rr = ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1)
            r.Copy rr
NextV:
            .AutoFilterMode = False
        End With
    Next v
    
    'Add sequential item numbers
    n = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row - 8
    ReDim a(1 To n)
    For i = 1 To n
        a(i) = i
    Next i
    With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(a))
       .Value = WorksheetFunction.Transpose(a)
        ws.Range("B9").Copy
        .PasteSpecial xlPasteFormats
    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub ClearBOM()
    Dim r As Range
    With Worksheets("Current BOM")
        .UsedRange.AutoFilter 1, ">0"
        Set r = Intersect(.Rows("9:" & .Rows.Count), .UsedRange)
    End With
    If Not r Is Nothing Then r.Clear
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by Kenneth Hobson.