Excel VBA - create a new workbook with specific rows from a table that meet a condition.

[Kyletok]

Hi,

On google I found a few methods for this which require to copy paste to another worksheet etc, but was wondering if there is an easier way to perform what I am trying to do.

I have a table called "Invoices" which has a column called "Status" (Column 14). What I need done, is a macro that will create an entirely new workbook in the file destination that I will set for it, and name the workbook a specific value (which I would define in a worksheet cell, in a worksheet called "Macro Helper"), and that new worksheet would have a table also called "Invoices", but it would have only pulled rows in which the status column value is "Approved".

additionally, on the main "Invoices" table, all the rows that have been extracted would now have "Complete" in the "Status" Column, so that next time a new report is generated, it would not extract them again since they no longer say "Approved". (on the extracted workbook they should also say "complete", which I hope doesnt confuse things.)

could anyone help me out with this?

 

[Kyletok]

thats what I have so far lol,
trying piece by piece until it works

Sub ExtractManager()
Dim LOC As String  'Define Cell with location
LOC = Sheets("Function_Reference").Range("B33")


    
    Set newbook = Workbooks.Add
    With newbook
        .Title = "Workbook Title"
        .Subject = "Workbook Subject"
        
        .SaveAs Filename:=LOC
        '.Close
    End With


End Sub

 

[DanteAmor]

I present a way to copy the data using the advanced filter



change B2 to the cell where you have the name of the new file

Sub Create_New_Workbook()
    Dim ruta As String, wbname As String
    Dim l1 As Workbook, l2 As Workbook
    Dim h1 As Worksheet, h2 As Worksheet
    Dim colf As Long, rng As Range
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(Range("Invoices").Worksheet.Name)
    '
    ruta = l1.Path & "\"
[COLOR=#0000ff]    wbname = l1.Sheets("Macro Helper").Range("B2").Value[/COLOR]
    '
    colf = h1.Range("invoices").Cells(1, 1).Column + Range("invoices").Columns.Count + 1
    h1.Cells(1, colf).Value = "Status"
    h1.Cells(2, colf).Value = "Approved"
    Set rng = h1.Range(h1.Cells(1, colf), h1.Cells(2, colf))
    Set l2 = Workbooks.Add
    Set h2 = l2.Sheets(1)
    h1.Range("Invoices[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=rng, CopyToRange:=h2.Range("A1"), Unique:=False
    '
    h2.ListObjects.Add(xlSrcRange, h2.Range("A1", h2.UsedRange), , xlYes).Name = "Invoices"
    h2.Range("Invoices[Status]").Value = "Complete"
    l2.SaveAs Filename:=ruta & wbname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close False
    '
    h1.Range("Invoices[Status]").Replace What:="Approved", Replacement:="Complete", LookAt:=xlPart
    rng.Value = ""
    '
    MsgBox "End"
End Sub

 

[Kyletok]

This works perfectly! thank you!

is there also a way to name the sheet on the new workbook?

 

[DanteAmor]

This works perfectly! thank you!

is there also a way to name the sheet on the new workbook?

With this:

Sub Create_New_Workbook()
    Dim ruta As String, wbname As String, [COLOR=#0000ff]wsName As String[/COLOR]
    Dim l1 As Workbook, l2 As Workbook
    Dim h1 As Worksheet, h2 As Worksheet
    Dim colf As Long, rng As Range
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(Range("Invoices").Worksheet.Name)
    '
    ruta = l1.Path & "\"
    wbname = l1.Sheets("Macro Helper").Range("B2").Value    'book name
[COLOR=#0000ff]    wsName = l1.Sheets("Macro Helper").Range("B3").Value    'sheet name[/COLOR]
    '
    colf = h1.Range("invoices").Cells(1, 1).Column + Range("invoices").Columns.Count + 1
    h1.Cells(1, colf).Value = "Status"
    h1.Cells(2, colf).Value = "Approved"
    Set rng = h1.Range(h1.Cells(1, colf), h1.Cells(2, colf))
    Set l2 = Workbooks.Add
    Set h2 = l2.Sheets(1)
[COLOR=#0000ff]    h2.Name = wsName[/COLOR]
    h1.Range("Invoices[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=rng, CopyToRange:=h2.Range("A1"), Unique:=False
    '
    h2.ListObjects.Add(xlSrcRange, h2.Range("A1", h2.UsedRange), , xlYes).Name = "Invoices"
    h2.Range("Invoices[Status]").Value = "Complete"
    l2.SaveAs Filename:=ruta & wbname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close False
    '
    h1.Range("Invoices[Status]").Replace What:="Approved", Replacement:="Complete", LookAt:=xlPart
    rng.Value = ""
    '
    MsgBox "End"
End Sub

 

[Kyletok]

With this:

Sub Create_New_Workbook()
    Dim ruta As String, wbname As String, [COLOR=#0000ff]wsName As String[/COLOR]
    Dim l1 As Workbook, l2 As Workbook
    Dim h1 As Worksheet, h2 As Worksheet
    Dim colf As Long, rng As Range
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(Range("Invoices").Worksheet.Name)
    '
    ruta = l1.Path & "\"
    wbname = l1.Sheets("Macro Helper").Range("B2").Value    'book name
[COLOR=#0000ff]    wsName = l1.Sheets("Macro Helper").Range("B3").Value    'sheet name[/COLOR]
    '
    colf = h1.Range("invoices").Cells(1, 1).Column + Range("invoices").Columns.Count + 1
    h1.Cells(1, colf).Value = "Status"
    h1.Cells(2, colf).Value = "Approved"
    Set rng = h1.Range(h1.Cells(1, colf), h1.Cells(2, colf))
    Set l2 = Workbooks.Add
    Set h2 = l2.Sheets(1)
[COLOR=#0000ff]    h2.Name = wsName[/COLOR]
    h1.Range("Invoices[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=rng, CopyToRange:=h2.Range("A1"), Unique:=False
    '
    h2.ListObjects.Add(xlSrcRange, h2.Range("A1", h2.UsedRange), , xlYes).Name = "Invoices"
    h2.Range("Invoices[Status]").Value = "Complete"
    l2.SaveAs Filename:=ruta & wbname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close False
    '
    h1.Range("Invoices[Status]").Replace What:="Approved", Replacement:="Complete", LookAt:=xlPart
    rng.Value = ""
    '
    MsgBox "End"
End Sub

perfect thank you!,

I have one more question, Your code works very smoothly and quick and doesnt load much despite having to do a bunch of things -
I have another report that we used for about a year where I just need to get all the values in the table, and this is what we used:

Sub CopyManager()
Set xls = CreateObject("Excel.Application")
xls.DisplayAlerts = False
Dim LOC As String  'Define Cell with location
LOC = Sheets("Function_Reference").Range("B33")
   
    Range("Invoices[#All]").Copy


     Set newbook = Workbooks.Add
     ActiveCell.PasteSpecial Paste:=xlPasteValues
    With newbook
        Dim tbl As ListObject
        Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
        tbl.Name = "Invoices"
        .Title = "Workbook Title"
        .Subject = "Workbook Subject"
        Application.DisplayAlerts = False
        .SaveAs Filename:=LOC
        .Close
    End With
    ActiveWorkbook.Save
    MsgBox "You have published your invoices to the Master List."
End Sub

what would you suggest on improving this one so it works faster?

 

[DanteAmor]

Try with this:

Sub CopyManager()




Application.DisplayAlerts = False
Application.ScreenUpdating = False


Dim LOC As String  'Define Cell with location
LOC = Sheets("Function_Reference").Range("B33")
   
    Range("Invoices[#All]").Copy




     Set newbook = Workbooks.Add
     ActiveCell.PasteSpecial Paste:=xlPasteValues
    With newbook
        Dim tbl As ListObject
        Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
        tbl.Name = "Invoices"
        .Title = "Workbook Title"
        .Subject = "Workbook Subject"
        Application.DisplayAlerts = False
        .SaveAs Filename:=LOC
        .Close
    End With
    ActiveWorkbook.Save
    MsgBox "You have published your invoices to the Master List."
End Sub