VBA Code - creating new workbooks for the data criteria from the existing excel sheet

[Rohith1324]

Hi I'm sharing the sample data below and really looking forward for the code which helps me in performing the task :

Task :

If you see the below data I have the Package information and status information against each row
when ever all the row line items for the particular package is showing the status as "TRUE" then that particular package rows including the headers should be copied to new excel workbook and the excel workbook to be named as Order Number Present in column A and include the package details in column E.xlsx
Even a single row for that particular package is showing the status as "False" then that package details are not required to be created as a new workbook

Order number	Material	Qty	Status	Package
2222222​	Item1	15​	TRUE​	Package1
2222222​	Item2	8​	TRUE​	Package1
2222222​	Item3	6​	TRUE​	Package1
2222222​	Item4	15​	TRUE​	Package1
2222222​	Item5	10​	TRUE​	Package1
2222222​	Item6	14​	TRUE​	Package1
444444​	Item45	7​	FALSE​	Package2
444444​	Item54	11​	TRUE​	Package2
888888​	Item1	7​	TRUE​	Pacakge3
888888​	Item66	2​	TRUE​	Pacakge3
9999999​	Item77	14​	FALSE​	Package4
9999999​	Item1	9​	FALSE​	Package4

 

[Trebor76]

Hi Rohith1324,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim dictPackages As Object
    Dim varPackage As Variant
    Dim i As Long, j As Long, k As Long
    Dim wbNewBook As Workbook
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
    Set dictPackages = CreateObject("Scripting.Dictionary")
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    j = 2: k = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'Build an unique list of packages and a count of FALSE for each
    'Note - FALSE is presumed to be the result of a logical function NOT simply a text entry
    For i = j To k
        If Not dictPackages.Exists(CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i))) Then
            dictPackages.Add CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i)), CLng(Evaluate("COUNTIFS('" & wsSrc.Name & "'!E" & j & ":E" & k & ",""" & CStr(wsSrc.Range("E" & i)) & """,'" & wsSrc.Name & "'!D" & j & ":D" & k & ",FALSE)"))
        End If
    Next i
    
    j = 0
    For i = 0 To dictPackages.Count - 1
        If dictPackages.Items()(i) = 0 Then
            j = j + 1
            wsSrc.Range("A1:E" & k).AutoFilter
            wsSrc.Range("A1:E" & k).AutoFilter Field:=5, Criteria1:=CStr(Split(dictPackages.Keys()(i), "|")(1))
            Workbooks.Add 1 'Create a new workbook with just one sheet
            Set wbNewBook = ActiveWorkbook
            wsSrc.Range("A1:E" & k).SpecialCells(xlCellTypeVisible).Copy
            wbNewBook.Sheets(1).Paste
            Application.CutCopyMode = False
            Application.DisplayAlerts = False
                wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
                wbNewBook.Close SaveChanges:=False
            Application.DisplayAlerts = True
            On Error Resume Next
                wsSrc.ShowAllData
            On Error GoTo 0
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    If j = 0 Then
        MsgBox "There were no files created as no packages had all records of a status of TRUE.", vbExclamation
    ElseIf j = 1 Then
        MsgBox "One file where each package record had a status of TRUE has now been created.", vbInformation
    Else
        MsgBox Format(j, "#,##0") & " files where each package record has a status of TRUE have now been created.", vbInformation
    End If

End Sub

Regards,

Robert

 

[Rohith1324]

Hi Rohith1324,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim dictPackages As Object
    Dim varPackage As Variant
    Dim i As Long, j As Long, k As Long
    Dim wbNewBook As Workbook
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
    Set dictPackages = CreateObject("Scripting.Dictionary")
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    j = 2: k = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    'Build an unique list of packages and a count of FALSE for each
    'Note - FALSE is presumed to be the result of a logical function NOT simply a text entry
    For i = j To k
        If Not dictPackages.Exists(CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i))) Then
            dictPackages.Add CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i)), CLng(Evaluate("COUNTIFS('" & wsSrc.Name & "'!E" & j & ":E" & k & ",""" & CStr(wsSrc.Range("E" & i)) & """,'" & wsSrc.Name & "'!D" & j & ":D" & k & ",FALSE)"))
        End If
    Next i
   
    j = 0
    For i = 0 To dictPackages.Count - 1
        If dictPackages.Items()(i) = 0 Then
            j = j + 1
            wsSrc.Range("A1:E" & k).AutoFilter
            wsSrc.Range("A1:E" & k).AutoFilter Field:=5, Criteria1:=CStr(Split(dictPackages.Keys()(i), "|")(1))
            Workbooks.Add 1 'Create a new workbook with just one sheet
            Set wbNewBook = ActiveWorkbook
            wsSrc.Range("A1:E" & k).SpecialCells(xlCellTypeVisible).Copy
            wbNewBook.Sheets(1).Paste
            Application.CutCopyMode = False
            Application.DisplayAlerts = False
                wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
                wbNewBook.Close SaveChanges:=False
            Application.DisplayAlerts = True
            On Error Resume Next
                wsSrc.ShowAllData
            On Error GoTo 0
        End If
    Next i
   
    Application.ScreenUpdating = True
   
    If j = 0 Then
        MsgBox "There were no files created as no packages had all records of a status of TRUE.", vbExclamation
    ElseIf j = 1 Then
        MsgBox "One file where each package record had a status of TRUE has now been created.", vbInformation
    Else
        MsgBox Format(j, "#,##0") & " files where each package record has a status of TRUE have now been created.", vbInformation
    End If

End Sub

Regards,

Robert

Hi Robert, thank you so much this works perfectly...but just a one change required that is when saving the file I as of now we are using Ordernumber.xlsx but can we have the file saved as orderNumber&package.xlsx pls

 

[Trebor76]

Hi Robert, thank you so much this works perfectly

That's great

but just a one change required that is when saving the file I as of now we are using Ordernumber.xlsx but can we have the file saved as orderNumber&package.xlsx pls

So assuming you mean like this...

2222222 Package1.xlsx

...change this line

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

To this:

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & " " & CStr(Split(dictPackages.Keys()(i), "|")(1)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

Regards,

Robert

 

[Rohith1324]

That's great



So assuming you mean like this...

2222222 Package1.xlsx

...change this line

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

To this:

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & " " & CStr(Split(dictPackages.Keys()(i), "|")(1)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

Regards,

Robert

thank you Robert...

 

[Rohith1324]

That's great



So assuming you mean like this...

2222222 Package1.xlsx

...change this line

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

To this:

wbNewBook.SaveAs ThisWorkbook.Path & "\" & CStr(Split(dictPackages.Keys()(i), "|")(0)) & " " & CStr(Split(dictPackages.Keys()(i), "|")(1)) & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.

Regards,

Robert

Hi Robert,

sorry to again bother you here...but there is slight change in the requirement ....if you could help me with that..
earlier when the complete package status was True we have created new excel sheet and copied it..

but now the requirement is for all those "where the complete package status is True" that should be copied and pasted just in one excel sheet instead of creating multiple excels for each package.

In the screenshot below I have package 1 and Package 3 Status for the respective lines is "True" so I wanted 1 New excel sheet with these 2 Packages row line information.


Note: Where even one of the row for the particular package is "False" then we should not take any action against that package.

thank you for your support.

 

[Trebor76]

Hi Rohith1324,

The attached produces nine records not eight as in your screen shot as you've missed highlighting Row 9. I also wasn't sure what to call the newly created file so you'll have to change the strSaveAsName variable to suit:

Option Explicit
Sub Macro2()

    'https://www.mrexcel.com/board/threads/vba-code-creating-new-workbooks-for-the-data-criteria-from-the-existing-excel-sheet.1230425/#post-6027971

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long
    Dim dblFltrRecCount As Double
    Dim wbNewBook As Workbook
    Dim strSaveAsName As String
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
    
    On Error Resume Next
        wsSrc.ShowAllData
        j = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If j = 0 Then
            MsgBox "There is no data on """ & wsSrc.Name & """ to work with.", vbExclamation
            Exit Sub
        End If
    On Error GoTo 0
    
    i = 1
    
    dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D" & i & ":D" & j & ",TRUE)")
    If dblFltrRecCount = 0 Then
        MsgBox "There is no status of TRUE in Col. D of the """ & wsSrc.Name & """ tab.", vbExclamation
        Exit Sub
    End If
    
    strSaveAsName = "Rohith1324" 'File name for newly created workbook with TRUE records only. Change to suit.
    
    wsSrc.Range("A" & i & ":E" & j).AutoFilter
    wsSrc.Range("A" & i & ":E" & j).AutoFilter Field:=4, Criteria1:=True
    
    Workbooks.Add 1 'Create a new workbook with just one sheet
    Set wbNewBook = ActiveWorkbook
    wsSrc.Range("A" & i & ":E" & j).SpecialCells(xlCellTypeVisible).Copy
    wbNewBook.Sheets(1).Paste
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .Goto Reference:=wbNewBook.Sheets(1).Range("A1"), Scroll:=True
        wbNewBook.SaveAs ThisWorkbook.Path & "\" & strSaveAsName & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
        wbNewBook.Close SaveChanges:=False
        .DisplayAlerts = True
    End With
    
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0

    Application.ScreenUpdating = True

    If dblFltrRecCount = 1 Then
        MsgBox strSaveAsName & ".xlsx has now been created with one status record equaling TRUE.", vbInformation
    Else
        MsgBox strSaveAsName & ".xlsx has now been created with " & Format(dblFltrRecCount, "#,##0") & " status records equaling TRUE.", vbInformation
    End If

End Sub

Regards,

Robert

 

[Rohith1324]

Hi Rohith1324,

The attached produces nine records not eight as in your screen shot as you've missed highlighting Row 9. I also wasn't sure what to call the newly created file so you'll have to change the strSaveAsName variable to suit:

Option Explicit
Sub Macro2()

    'https://www.mrexcel.com/board/threads/vba-code-creating-new-workbooks-for-the-data-criteria-from-the-existing-excel-sheet.1230425/#post-6027971

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long
    Dim dblFltrRecCount As Double
    Dim wbNewBook As Workbook
    Dim strSaveAsName As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
   
    On Error Resume Next
        wsSrc.ShowAllData
        j = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If j = 0 Then
            MsgBox "There is no data on """ & wsSrc.Name & """ to work with.", vbExclamation
            Exit Sub
        End If
    On Error GoTo 0
   
    i = 1
   
    dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D" & i & ":D" & j & ",TRUE)")
    If dblFltrRecCount = 0 Then
        MsgBox "There is no status of TRUE in Col. D of the """ & wsSrc.Name & """ tab.", vbExclamation
        Exit Sub
    End If
   
    strSaveAsName = "Rohith1324" 'File name for newly created workbook with TRUE records only. Change to suit.
   
    wsSrc.Range("A" & i & ":E" & j).AutoFilter
    wsSrc.Range("A" & i & ":E" & j).AutoFilter Field:=4, Criteria1:=True
   
    Workbooks.Add 1 'Create a new workbook with just one sheet
    Set wbNewBook = ActiveWorkbook
    wsSrc.Range("A" & i & ":E" & j).SpecialCells(xlCellTypeVisible).Copy
    wbNewBook.Sheets(1).Paste
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .Goto Reference:=wbNewBook.Sheets(1).Range("A1"), Scroll:=True
        wbNewBook.SaveAs ThisWorkbook.Path & "\" & strSaveAsName & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
        wbNewBook.Close SaveChanges:=False
        .DisplayAlerts = True
    End With
   
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0

    Application.ScreenUpdating = True

    If dblFltrRecCount = 1 Then
        MsgBox strSaveAsName & ".xlsx has now been created with one status record equaling TRUE.", vbInformation
    Else
        MsgBox strSaveAsName & ".xlsx has now been created with " & Format(dblFltrRecCount, "#,##0") & " status records equaling TRUE.", vbInformation
    End If

End Sub

Regards,

Robert

Hi Robert, I have highlighted it correctly... Row line 9 the value is TRUE but the package is different(Package2) . It should always check Status column + Package column and when the complete package value is True then we should consider it to copy to the new sheet. In this case only for Package1 and for Package3 all row status is TRUE.

 

[Trebor76]

Ah now I see (hopefully ) - try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim dictPackages As Object
    Dim varPackage As Variant
    Dim i As Long, j As Long, k As Long, x As Long
    Dim dblFltrRecCount As Double
    Dim wbNewBook As Workbook
    Dim strSaveAsName As String
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
    Set dictPackages = CreateObject("Scripting.Dictionary")
    On Error Resume Next
        k = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If k = 0 Then
            MsgBox "There is no data on """ & wsSrc.Name & """ to work with.", vbExclamation
            Exit Sub
        End If
        wsSrc.ShowAllData
        dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D:D,TRUE)")
        If dblFltrRecCount = 0 Then
            MsgBox "There is no status of TRUE in Col. D of the """ & wsSrc.Name & """ tab.", vbExclamation
            Exit Sub
        End If
    On Error GoTo 0
    j = 2
    
    'Build an unique list of packages and a count of FALSE for each
    'Note - FALSE is presumed to be the result of a logical function NOT simply a text entry
    For i = j To k
        If Not dictPackages.Exists(CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i))) Then
            dictPackages.Add CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i)), CLng(Evaluate("COUNTIFS('" & wsSrc.Name & "'!E" & j & ":E" & k & ",""" & CStr(wsSrc.Range("E" & i)) & """,'" & wsSrc.Name & "'!D" & j & ":D" & k & ",FALSE)"))
        End If
    Next i
    
    j = 0
    For i = 0 To dictPackages.Count - 1
        If dictPackages.Items()(i) = 0 Then
            If wbNewBook Is Nothing Then
                Workbooks.Add 1 'Create a new workbook with just one sheet
                Set wbNewBook = ActiveWorkbook
            End If
            j = j + 1
            If x = 0 Then
                x = 1
            Else
                x = wbNewBook.Sheets(1).Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            wsSrc.Range("A1:E" & k).AutoFilter
            wsSrc.Range("A1:E" & k).AutoFilter Field:=5, Criteria1:=CStr(Split(dictPackages.Keys()(i), "|")(1))
            'Copy headers only for the first copy
            wsSrc.Range("A1:E" & k).Offset(IIf(j = 1, 0, 1)).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNewBook.Sheets(1).Range("A" & x)
            Application.CutCopyMode = False
        End If
    Next i
    
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    
    With Application
        .DisplayAlerts = False
        .Goto Reference:=wbNewBook.Sheets(1).Range("A1"), Scroll:=True
        strSaveAsName = "Rohith1324" 'File name for newly created workbook with TRUE records only. Change to suit.
        dblFltrRecCount = Evaluate("COUNTIF('[" & wbNewBook.Name & "]Sheet1'!$D:$D,TRUE)")
        wbNewBook.SaveAs ThisWorkbook.Path & "\" & strSaveAsName & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
        wbNewBook.Close SaveChanges:=False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    If dblFltrRecCount = 1 Then
        MsgBox strSaveAsName & ".xlsx has now been created with one status record equaling TRUE.", vbInformation
    Else
        MsgBox strSaveAsName & ".xlsx has now been created with " & Format(dblFltrRecCount, "#,##0") & " status records equaling TRUE.", vbInformation
    End If

End Sub

Regards,

Robert

 

[Rohith1324]

T

Ah now I see (hopefully ) - try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim dictPackages As Object
    Dim varPackage As Variant
    Dim i As Long, j As Long, k As Long, x As Long
    Dim dblFltrRecCount As Double
    Dim wbNewBook As Workbook
    Dim strSaveAsName As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Name of sheet containing the data. Change to suit.
    Set dictPackages = CreateObject("Scripting.Dictionary")
    On Error Resume Next
        k = wsSrc.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If k = 0 Then
            MsgBox "There is no data on """ & wsSrc.Name & """ to work with.", vbExclamation
            Exit Sub
        End If
        wsSrc.ShowAllData
        dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D:D,TRUE)")
        If dblFltrRecCount = 0 Then
            MsgBox "There is no status of TRUE in Col. D of the """ & wsSrc.Name & """ tab.", vbExclamation
            Exit Sub
        End If
    On Error GoTo 0
    j = 2
   
    'Build an unique list of packages and a count of FALSE for each
    'Note - FALSE is presumed to be the result of a logical function NOT simply a text entry
    For i = j To k
        If Not dictPackages.Exists(CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i))) Then
            dictPackages.Add CStr(wsSrc.Range("A" & i)) & "|" & CStr(wsSrc.Range("E" & i)), CLng(Evaluate("COUNTIFS('" & wsSrc.Name & "'!E" & j & ":E" & k & ",""" & CStr(wsSrc.Range("E" & i)) & """,'" & wsSrc.Name & "'!D" & j & ":D" & k & ",FALSE)"))
        End If
    Next i
   
    j = 0
    For i = 0 To dictPackages.Count - 1
        If dictPackages.Items()(i) = 0 Then
            If wbNewBook Is Nothing Then
                Workbooks.Add 1 'Create a new workbook with just one sheet
                Set wbNewBook = ActiveWorkbook
            End If
            j = j + 1
            If x = 0 Then
                x = 1
            Else
                x = wbNewBook.Sheets(1).Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            wsSrc.Range("A1:E" & k).AutoFilter
            wsSrc.Range("A1:E" & k).AutoFilter Field:=5, Criteria1:=CStr(Split(dictPackages.Keys()(i), "|")(1))
            'Copy headers only for the first copy
            wsSrc.Range("A1:E" & k).Offset(IIf(j = 1, 0, 1)).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNewBook.Sheets(1).Range("A" & x)
            Application.CutCopyMode = False
        End If
    Next i
   
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
   
    With Application
        .DisplayAlerts = False
        .Goto Reference:=wbNewBook.Sheets(1).Range("A1"), Scroll:=True
        strSaveAsName = "Rohith1324" 'File name for newly created workbook with TRUE records only. Change to suit.
        dblFltrRecCount = Evaluate("COUNTIF('[" & wbNewBook.Name & "]Sheet1'!$D:$D,TRUE)")
        wbNewBook.SaveAs ThisWorkbook.Path & "\" & strSaveAsName & ".xlsx", FileFormat:=51 'Saves the workbook in xlsx format in the same path as this workbook. Will also overwrite an existing file of the same name no questions asked. Change to suit.
        wbNewBook.Close SaveChanges:=False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
   
    If dblFltrRecCount = 1 Then
        MsgBox strSaveAsName & ".xlsx has now been created with one status record equaling TRUE.", vbInformation
    Else
        MsgBox strSaveAsName & ".xlsx has now been created with " & Format(dblFltrRecCount, "#,##0") & " status records equaling TRUE.", vbInformation
    End If

End Sub

Regards,

Robert

Thank you Robert...this works for the requirement...