VBA Loop that copies filtered data until list is complete

[GH20V]

Hi,

This is my first post so I hope this makes sense.

Currently I have three sheets, "Orders", "BOMList" and "TotalBOMs". What I am trying to do is get a bill of materials for multiple orders in the “TotalBOMs” sheet. At the moment I put the order number in Cell A1 and then use a =filter command to retrieve the list of parts related to that order. Then in the next empty cell I add the next order number and use the filter command again, and so on.

The sheets are as below,
"Orders" sheet has current order numbers I want to extract listed in column "A",
"BOMList" Sheet has a list of all Part numbers (Column A), Quantities (Column B) and Order numbers (column C),
"TotalBOMs" sheet has the order number (Column A), Part number (Column B) and Qty (Column C).

What I am wanting to do is run a macro that will run through the list of order numbers in "Orders" and add the information relating to them from "BOMList" into "TotalBOMs".

I’m not to sure where to start as I thought I might run a loop that steps through the order numbers and writes the filtered information to the next empty cell in the TotalBOMs sheet but it has proved beyond my abilities.
Thanks to anyone that can help.

 

[kevin9999]

Maybe this?

Option Explicit
Sub GH20V()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Orders")
    Set ws2 = Worksheets("BOMList")
    Set ws3 = Worksheets("TotalBOMs")
    
    Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
    Set rngList = ws2.Range("A1").CurrentRegion
    
    ws1.Range("A1").Insert xlDown
    ws1.Range("A1").Value = "Order #"
    Set rngCriteria = ws1.Range("A1").CurrentRegion
    
    ws3.Cells.ClearContents
    ws3.Range("A1").Resize(1, 3).Value = Array("Order #", "Part #", "Qty")
    Set rngCopyTo = ws3.Range("A1:C1")
    
    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
    
    With ws3
        .Range("A1").Resize(1, 3).Value = Array("Order number", "Part number", "Qty")
        .Columns.AutoFit
        .Range("C:C").NumberFormat = "0"
    End With
    
    ws1.Range("A1").EntireRow.Delete
End Sub

 

[GH20V]

Maybe this?

Option Explicit
Sub GH20V()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Orders")
    Set ws2 = Worksheets("BOMList")
    Set ws3 = Worksheets("TotalBOMs")
   
    Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
    Set rngList = ws2.Range("A1").CurrentRegion
   
    ws1.Range("A1").Insert xlDown
    ws1.Range("A1").Value = "Order #"
    Set rngCriteria = ws1.Range("A1").CurrentRegion
   
    ws3.Cells.ClearContents
    ws3.Range("A1").Resize(1, 3).Value = Array("Order #", "Part #", "Qty")
    Set rngCopyTo = ws3.Range("A1:C1")
   
    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
   
    With ws3
        .Range("A1").Resize(1, 3).Value = Array("Order number", "Part number", "Qty")
        .Columns.AutoFit
        .Range("C:C").NumberFormat = "0"
    End With
   
    ws1.Range("A1").EntireRow.Delete
End Sub

This is exactly what I was after. Thank you so much for your help.

 

[kevin9999]

This is exactly what I was after. Thank you so much for your help.

You're welcome, and thanks for the feedback

 

[kevin9999]

I think you may have marked the wrong post as the solution?