Copy Data From Multiple Sheets into Master Sheet if Cell Value >0

[VanillaBryce]

Good evening all!

I have a baseball card collection I have catalogued in about 70 sheets, each sheet named for a year 1950-2020. Each card has a row with data in columns A:H. Columns A:G are identifying information for the card (i.e., Year, Brand, Set, Subset, Number, Name, Style). Column H is "Quantity" and... has a numerical value representing the quantity of that particular card I have in my collection.

I want to create a new sheet called All Owned that lists every card I own. In other words, I need some kind of formula or macro that will automatically search column H in all 70 sheets, and if the value in H is greater than 0, then it will copy and paste all information in the same row A:H.

Ideally, I would like this All Owned sheet to automatically update as I update my collection in the sheets labelled 1950-2020. Thank you!

 

[kevin9999]

OK, there's a couple of different requests you've made here. I've provided the code for the first part below, and if you confirm that it has worked exactly as it should, we can progress to the next part, which is the automatic updating. The code assumes you already have a sheet in your workbook called "All Owned", and that the headers in each sheet (including All Owned) are in row 1. The first code will consolidate all the sheets' data to the All Owned sheet where column H in each sheet is greater than 0. Let me know if this works and we can progress to the next step.

Option Explicit
Sub Consolidate_All_Owned()
    Dim i As Long, lr As Long, owned As Long, ws As Worksheet
    Set ws = Worksheets("All Owned")
    Application.ScreenUpdating = False
    For i = 1 To ThisWorkbook.Sheets.Count
        If Worksheets(i).Name <> "All Owned" Then
            lr = ws.Cells(Rows.Count, 1).End(3).Row + 1
            With Worksheets(i).Cells(1).CurrentRegion
                .AutoFilter 8, ">0"
                .Offset(1).Copy ws.Cells(lr, 1)
                .AutoFilter
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[VanillaBryce]

Thank you so much. That runs like a charm! Everything is now appearing in the "All Owned" sheet perfectly. Thanks so much. What's next?

 

[kevin9999]

Thank you so much. That runs like a charm! Everything is now appearing in the "All Owned" sheet perfectly. Thanks so much. What's next?

Thanks for the feedback. Next will be the automatic updating, but due to time zone differences, it'll be a few hours before I can get to it. Things are looking promising though... ?

 

[kevin9999]

So far so good. Next is a 3 step process.

Step 1 – replace the existing code. The Consolidate_All_Owned() sub was only ever intended to do the initial setup. If you run it again, it will duplicate your records on the ‘All Owned’ sheet, which you don’t want. Delete that sub routine and replace it with the first code below – the Add_New_Year() sub routine. The difference is that the new sub will delete existing records on the ‘All Owned’ sheet before copying all the relevant records from each individual sheet. The idea is that you run it whenever you add a new year (sheet) to your workbook – and don’t worry, you won’t do any damage if you run it at any time, no records will be lost.

Step 2 – add the code that updates the ‘All Owned’ sheet whenever there’s a change to the ‘year’ sheets. Just put the sub routine Update_Sheet_Change() underneath the Add_New_YYear() sub routine. It will run whenever it’s triggered by the code in step 3. Once you’ve done steps 1 & 2 your module will look like this:

Option Explicit
Sub Add_New_Year()
    Dim i As Long, lr As Long, ws As Worksheet
    Set ws = Worksheets("All Owned")
    Application.ScreenUpdating = False
    
    ws.UsedRange.Offset(1).ClearContents
    For i = 1 To ThisWorkbook.Sheets.Count
        If Worksheets(i).Name <> "All Owned" Then
            lr = ws.Cells(Rows.Count, 1).End(3).Row + 1
            With Worksheets(i).Cells(1).CurrentRegion
                .AutoFilter 8, ">0"
                .Offset(1).Copy ws.Cells(lr, 1)
                .AutoFilter
            End With
        End If
    Next i
    
    ws.UsedRange.Sort Key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlYes
    Application.ScreenUpdating = True
End Sub
Sub Update_Sheet_Change()
    Dim yr As String, lr As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("All Owned")
    Set ws2 = ActiveSheet
    yr = ws2.Cells(2, 1)
    Application.ScreenUpdating = False
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 1, yr
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With
    lr = ws1.Cells(Rows.Count, 1).End(3).Row + 1
    
    With ws2.Cells(1).CurrentRegion
        .AutoFilter 8, ">0"
        .Offset(1).Copy ws1.Cells(lr, 1)
        .AutoFilter
    End With
    
    ws1.UsedRange.Sort Key1:=ws1.Range("A1"), order1:=xlAscending, Header:=xlYes
    Application.ScreenUpdating = True
End Sub

Step 3 – add the individual sheets’ code. This will be a pain for you because you’ll have to do it to every sheet except the ‘All Owned’ sheet. The code is the same for every sheet so you can copy & paste. It doesn’t go in a standard module but in the code area of the sheets. To access the sheet code area, right-click on the sheet tab name and select View Code. You put the sheet code in the area on the right of the screen that appears. Alternatively, you can open the VBA Editor (press Alt+F11) and in the VBA Project window (top left) double-click on each sheet name & the code window for that sheet will appear.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Range("H:H"), Target) Is Nothing Then
        Update_Sheet_Change
    End If
    Application.EnableEvents = True
End Sub

Once you’ve put all the code in place, save your workbook & test it out. Let me know how you go.

 

[VanillaBryce]

Thank you! But... When I enter a new quantity in a current sheet- for example, if I add "1" into the quantity for a new card just as an experiment- "Compile Error: Sub or Function Not Defined."

Thoughts?

 

[kevin9999]

Thank you! But... When I enter a new quantity in a current sheet- for example, if I add "1" into the quantity for a new card just as an experiment- "Compile Error: Sub or Function Not Defined."

Thoughts?

Could you indicate which line of code is highlighted when the error occurs?

 

[VanillaBryce]

Also, if it helps, the top line in the in that worksheet's code is highlighted with a yellow arrow proceeding it, point to the text on that line. I've attached a screen grab of what I am prompted with after entering a new quantity in any existing sheet.

 

[kevin9999]

OK, try saving the workbook, closing it & reopen it. See if that makes any difference.

 

[VanillaBryce]

Same exact error. When I exit out of the Microsoft VB for Applications dialogue box, I get another error that says "This command will stop the debugger."

Then, when I delete the experimental "1" I entered, it goes through the same cycle of errors: the Command Error mentioned above, the highlighted text, the debugger notification.