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]

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

You're welcome. Glad we got there in the end.

 

[Tom.Jones]

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

@Trebor76 or,

I used the same data (as used by the OP)
and when running the penultimate and last VBA code, I get the error:
"There is no status of TRUE in Col. D of the Sheet1 tab."
Where am I wrong?

 

[Trebor76]

Where am I wrong?

Not sure as it worked for me

First things first - there are entries in Col. D of Sheet1 that say TRUE? If so try this formula in Sheet1 in any blank cell that references one of those cells (D2 in the following for example):

=IF(D2=TRUE(),1,0)

If 1 is returned it is actually TRUE so I have no idea why it's not working. If 0 is returned it's not actually TRUE in the boolean definition and why I put in the comment in the code "Note - FALSE is presumed to be the result of a logical function NOT simply a text entry".

Robert

 

[Tom.Jones]

Yes. You're wright.
That 'TRUE' was text.

first VBA code work with text 'true'.

Thank you.

 

[Trebor76]

If it's text I think you need something like this:

dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D:D,""TRUE*"")")

 

[Tom.Jones]

If it's text I think you need something like this:

dblFltrRecCount = Evaluate("COUNTIF('" & wsSrc.Name & "'!D:D,""TRUE*"")")

Yes. It works without '*' after TRUE.
Thank you.