Copy rows and column headings to new workbook based on cell value

[Daph1990]

Hello everyone,

Hoping someone can help. I've got some data in a table and one of the columns (L) has a value of "Yes" or "No". I would like a code to be able to copy across columns B, C, D, E and K to a new workbook (along with the column headings) if Column L has a value of "No".

After this I would then like to be able to split the newly copied data into separate tabs based on Column C. So for example if column C says "Property" I'd like all those that say "Property" on its own tab and I'd like this to continue across all the different categories in column C (6 different categories included).

This far I've only managed to add a new workbook but I get a little stuck after that. I've attached a dummy file showing what the data looks like. This is the code I have so far:

Dim wb As WorkbookDim FileName As String


Set wb = Workbooks.Add
Application.DisplayAlerts = False


fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")


'If user has specified file name, perform Save and display a message box
    If fileSaveName <> False Then
        ActiveWorkbook.SaveAs FileName:=fileSaveName, FileFormat:=52
    
        MsgBox "Save as " & fileSaveName
    End If


Application.DisplayAlerts = True

Thank you so much!

[mana]

you can use advancedfilter

Option Explicit


Sub test()
    Dim ws As Worksheet
    Dim r As Range
    Dim c As Range
    Dim wb As Workbook
    
    Set ws = Sheets("All Suppliers")
    Set r = ws.Range("a18", Range("a" & Rows.Count).End(xlUp)).Resize(, 12)
    Set c = ws.Range("o1")
    
    r.Columns("c").AdvancedFilter xlFilterCopy, , c, True
    c.Offset(, 1).Value = r.Range("L1").Value
    c.Offset(1, 1).Value = "No"
    
    Set wb = Workbooks.Add(xlWBATWorksheet)
     
    Do While c.Offset(1).Value <> ""
        With wb.Worksheets.Add
            .Name = c.Offset(1).Value
            r.Range("b1:e1,k1").Copy .Range("a1")
            r.AdvancedFilter xlFilterCopy, c.Resize(2, 2), .Range("a1:e1")
        End With
        c.Offset(1).Delete xlShiftUp
    Loop
    
    c.Resize(2, 2).ClearContents
    Application.DisplayAlerts = False
    wb.Sheets(wb.Sheets.Count).Delete
    Application.DisplayAlerts = True
    
End Sub

マナ

[Daph1990]

Omg @mana thank you so much, it worked an absolute treat. You've saved me so much time, and with such a short and elegant piece of code. Thank you!!!

[Daph1990]

@mana everything works perfectly but the way I wanted this code to work is that I wanted there to be a button on another sheet that runs this code. But this only seems to work when the sheet 'All Suppliers' is active. Is there a way to amend this so any sheet can be active when the button is pressed?

[mana]

??

> Set ws = Sheets("All Suppliers")

Set ws = Activesheet

[Daph1990]

Maybe I'm not explaining properly. This code works great and I do want it to be ws=Sheets("All Suppliers") because that's where all the data is, but when I place a button on another sheet and run this code I get the error on line

 Set r = ws.Range("a18", Range("a" & Rows.Count).End(xlUp)).Resize(, 12)

and was wondering why that would happen because I didn't think it would matter which sheet I run the code from

[mana]

Sorry

>Set r = ws.Range("a18", Range("a" & Rows.Count).End(xlUp)).Resize(, 12)

Set r = ws.Range("a18", ws.Range("a" & Rows.Count).End(xlUp)).Resize(, 12)

[Daph1990]

Perfect, such a simple fix. Thank you again!!!