Msg box in a destination xlsm if no results are found in source xlsx

[Gtasios4]

Hi All,

I have in my xlsm file the below VBA code that filters data of a source workbook xlsx by today's date in hidden mode and pastes those results in a destination xlsm workbook.

The VBA code works perfectly fine, however I don't get any msg box when no results is found. Any hint on that as to how I will fix it will be very helpful

Sub FilterTableByDate()
    Dim sourceWorkbook As Workbook
    Dim destinationWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim destinationWorksheet As Worksheet
    Dim sourceTable As ListObject
    Dim destinationTable As ListObject
    Dim todayDate As Date
    Dim filterRange As Range
    
    'Set the source and destination workbook and worksheet
    Set destinationWorkbook = ThisWorkbook 'Assuming the code is in the destination workbook
    Set destinationWorksheet = destinationWorkbook.Worksheets("Today's Deliveries")
    
    'Open the source workbook in hidden mode
    Set sourceWorkbook = Workbooks.Open(Filename:="\\argsrv\Users\Sales\Unit-Dell\DELL 2022\Deliveries\Deliveries 2022.xlsx", ReadOnly:=True, Password:="", WriteResPassword:="", IgnoreReadOnlyRecommended:=True, Editable:=False, UpdateLinks:=True, CorruptLoad:=xlNormalLoad)
    Set sourceWorksheet = sourceWorkbook.Worksheets("Deliveries")
    
    'Get today's date
    todayDate = Date
    
    'Filter the source sheet based on today's date
    Set filterRange = sourceWorksheet.Range("A1").CurrentRegion
    filterRange.AutoFilter Field:=7, Criteria1:="=" & Format(todayDate, "dd/m/yyyy")
    
    'Check if there are any results
    If filterRange.Rows.Count <= 1 Then
        MsgBox "No deliveries for today"
        sourceWorkbook.Close SaveChanges:=False
        Exit Sub
    End If
    
    'Copy the filtered results to the destination workbook
    filterRange.SpecialCells(xlCellTypeVisible).Copy
    destinationWorksheet.Range("A1").PasteSpecial xlPasteAll
        
    'Remove the filter from the source sheet
    filterRange.AutoFilter
    
    'Close the source workbook
    sourceWorkbook.Close SaveChanges:=False
End Sub

Best Regards

 

[HaHoBe]

Hi Gtasios4,

with

    Set filterRange = sourceWorksheet.Range("A1").CurrentRegion

you build a range holding the entire rows and coloumns directly connected to A1 and by using

    If filterRange.Rows.Count <= 1 Then

you check the entire range no matter if rows are hidden - the result will always be the number of rows for the basic filterRange..

Try using

    If filterRange.SpecialCells(xlCellTypeVisible).Rows.Count <= 1 Then

or

    If sourceWorkbook.Range("A" & sourceWorkbook.Rows.Count).End(xlUp).Row = 1 Then

instead.

Ciao,
Holger

 

[Gtasios4]

Hi Gtasios4,

with

    Set filterRange = sourceWorksheet.Range("A1").CurrentRegion

you build a range holding the entire rows and coloumns directly connected to A1 and by using

    If filterRange.Rows.Count <= 1 Then

you check the entire range no matter if rows are hidden - the result will always be the number of rows for the basic filterRange..

Try using

    If filterRange.SpecialCells(xlCellTypeVisible).Rows.Count <= 1 Then

or

    If sourceWorkbook.Range("A" & sourceWorkbook.Rows.Count).End(xlUp).Row = 1 Then

instead.

Ciao,
Holger

Hi Holger,

Thank you for your kind reply. I've replaced in the code with the one's you suggest as followed but it doesn't operates as I want. Instead it makes visible the source xlsx filters the results and also gives the msg box

   'Check if there are any results
        If filterRange.SpecialCells(xlCellTypeVisible).Rows.Count <= 1 Then
        MsgBox "No deliveries for today"
        sourceWorkbook.Close SaveChanges:=False
        Exit Sub
    End If

To briefly describe, I have an xlsx source data with deliveries in rows and there is also a column with the date.

My point is with the above mentioned code to copy the today's deliveries and then pasting into the destination xlsm. If no today's deliveries are found under the headers of the source file then pop a msg box "no deliveries for today"

 

[HaHoBe]

Hi Gtasios4,

please give this updated code a try (I had some trouble with CLng(Date) as well as CDbl(Date) being accepted as criteria to return data for today):

Sub FilterTableByDate()
' https://www.mrexcel.com/board/threads/msg-box-in-a-destination-xlsm-if-no-results-are-found-in-source-xlsx.1230257/
    Dim sourceWorkbook As Workbook
    Dim destinationWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim destinationWorksheet As Worksheet
    Dim sourceTable As ListObject
    Dim destinationTable As ListObject
    '/// changed Type from Date to String for next Variable
    Dim todayDate As String
    Dim filterRange As Range
    
    'Set the source and destination workbook and worksheet
    Set destinationWorkbook = ThisWorkbook 'Assuming the code is in the destination workbook
    Set destinationWorksheet = destinationWorkbook.Worksheets("Today's Deliveries")
    
    'Open the source workbook in hidden mode
    Set sourceWorkbook = Workbooks.Open(Filename:="\\argsrv\Users\Sales\Unit-Dell\DELL 2022\Deliveries\Deliveries 2022.xlsx", ReadOnly:=True, Password:="", WriteResPassword:="", IgnoreReadOnlyRecommended:=True, Editable:=False, UpdateLinks:=True, CorruptLoad:=xlNormalLoad)
    Set sourceWorksheet = sourceWorkbook.Worksheets("Deliveries")
    
    'Get today's date
    '/// changed to build the Date in a way that the filter for Today was successfull
    todayDate = Format(Date, "m\/d\/yyyy")
    
    'Filter the source sheet based on today's date
    Set filterRange = sourceWorksheet.Range("A1").CurrentRegion
    '/// changed the criteria for AutoFilter as in my workbook the conversion of Date with CLng or CDbl for AutoFilter did not work
    filterRange.AutoFilter Field:=7, _
                            Operator:=xlFilterValues, _
                            Criteria2:=Array(2, todayDate)
    
    'Check if there are any results
    '/// used checking for the last visible row on the sheet to determine if there are records
    If sourceWorkbook.Range("A" & sourceWorkbook.Rows.Count).End(xlUp).Row < 2 Then
        MsgBox "No deliveries for today"
        sourceWorkbook.Close SaveChanges:=False
        Exit Sub
    End If
    
    'Copy the filtered results to the destination workbook
    filterRange.SpecialCells(xlCellTypeVisible).Copy
    destinationWorksheet.Range("A1").PasteSpecial xlPasteAll
        
    'Remove the filter from the source sheet
    filterRange.AutoFilter
    
    'Close the source workbook
    sourceWorkbook.Close SaveChanges:=False
End Sub

Regarding Instead it makes visible the source xlsx filters: AFAIK that is the custom way for applying AutoFilter, you would need to set the Visibledropdown for each column to False in order not to show them.

Holger