excel - VBA for checking empty cells below header after filtering - Stack Overflow

admin管理员组

文章数量:1389903

I have made a macro which should filter on a sheet, if there is match , then it should copy the data with the header (later put it into email), if there is no match ,then it should go to the next item in the loop.

Right now, even if I inly have the header after filtering, the macro copies the header instead of just moving on to ne next item,

As below, firstVisibleCellinscope should be the data visible after filtering below the header, if it is empty then the loops should move on. Unfortunately he macro copies the header instead (as per as on the attached image) of just moving on to ne next item. With items where there is a match, the macro works , copies all the data.

    On Error Resume Next 
    ' Prevent error if no visible cells exist 
    For I = lastRowTeams To 2 Step -1 
    
        Team = wsTeamdata.Cells(I, 1) 
        emailaddress = wsTeamdata.Cells(I, 2) 
        
        Worksheets("In Scope").Activate 
        With Worksheets("In Scope").Range("A1") 
            .AutoFilter Field:=18, Criteria1:=Team 
        End With 
        
        Set firstVisibleCellinscope = wsInscope.Range("A2:A" & lastRowInscope).SpecialCells(xlCellTypeVisible) 
        
        If firstVisibleCellinscope Is Nothing Then GoTo NextIteration
        
        Set DatatoCopy = ActiveSheet.Range("A:K") 
        DatatoCopy.Copy 
NextIteration: 
    Next I

I have made a macro which should filter on a sheet, if there is match , then it should copy the data with the header (later put it into email), if there is no match ,then it should go to the next item in the loop.

Right now, even if I inly have the header after filtering, the macro copies the header instead of just moving on to ne next item,

As below, firstVisibleCellinscope should be the data visible after filtering below the header, if it is empty then the loops should move on. Unfortunately he macro copies the header instead (as per as on the attached image) of just moving on to ne next item. With items where there is a match, the macro works , copies all the data.

    On Error Resume Next 
    ' Prevent error if no visible cells exist 
    For I = lastRowTeams To 2 Step -1 
    
        Team = wsTeamdata.Cells(I, 1) 
        emailaddress = wsTeamdata.Cells(I, 2) 
        
        Worksheets("In Scope").Activate 
        With Worksheets("In Scope").Range("A1") 
            .AutoFilter Field:=18, Criteria1:=Team 
        End With 
        
        Set firstVisibleCellinscope = wsInscope.Range("A2:A" & lastRowInscope).SpecialCells(xlCellTypeVisible) 
        
        If firstVisibleCellinscope Is Nothing Then GoTo NextIteration
        
        Set DatatoCopy = ActiveSheet.Range("A:K") 
        DatatoCopy.Copy 
NextIteration: 
    Next I

• excel
• vba

Share Improve this question Follow edited Mar 15 at 19:31 CDP1802 16.5k22 gold badges1010 silver badges1818 bronze badges asked Mar 14 at 13:12 user29975215user29975215 1 4

• 1 Maybe show us more of the code? Are you using any error handling or On Error Resume Next? What row are your headers on? If there are no visible cells then that would raise a run-time error, and not return Nothing to firstVisibleCellinscope ... – Tim Williams Commented Mar 14 at 15:05
• Please find below: On Error Resume Next ' Prevent error if no visible cells exist For I = lastRowTeams To 2 Step -1 Team = wsTeamdata.Cells(I, 1) emailaddress = wsTeamdata.Cells(I, 2) Worksheets("In Scope").Activate With Worksheets("In Scope").Range("A1") .AutoFilter Field:=18, Criteria1:=Team End With Set firstVisibleCellinscope = wsInscope.Range("A2:A" & lastRowInscope).SpecialCells(xlCellTypeVisible) If firstVisibleCellinscope Is Nothing Then GoTo NextIteration Set DatatoCopy = ActiveSheet.Range("A:K") DatatoCopy.Copy NextIteration: Next I – user29975215 Commented Mar 15 at 16:37
• You can delete your comment as I have included that code in your post – CDP1802 Commented Mar 15 at 19:32
• You need to set firstVisibleCellinscope to Nothing before the call to SpecialCells – Tim Williams Commented Mar 15 at 21:07

Add a comment  | 

2 Answers 2

Sorted by: Reset to default 0

This might be more than what you are asking for, but here's some guidelines that I think would help to make your code more reliable and efficient:

1. Instead of looping through cells, copy the whole range into an array and loop through the array. There's too much overhead involved when looping through cells as they are part of Excel's object model. Arrays are stored in the computer's RAM...making them much faster to access for data validation and manipulation.

2. To ensure that you are accessing all the data intended to be captured, try to have all of the data in a table instead of just a range. It's much easier to assign a whole table column to an array vs trying to reference a range with an address along with trying to find the last row with data populated.

Here's an example of how to apply the guidelines listed above:

Let's pretend you have a worksheet with a list of Books. There are 3 attributes/headers listed: Date, Title, and Author.

As you can see, some cells are missing data.

Applying the guidelines listed above, the first step would be to convert this range to a table. This can be done by highlighting the whole range and pressing CTRL + T:

Next step, change the name of the table to "Books" (without quotation marks):

Note: For this example, I've also changed the name of the worksheet to "Books".

Next, we can start writing the code. Let's say you want to extract each populated cell for each column and send the data to a separate subroutine that handles sending out emails. It can be written like this:

Public Sub ExportData()
    Dim BooksTable    As ListObject   '- This is for storing the table.  
    Dim Buffer        As Variant      '- This is the array for storing the  
                                      '  data extracted from the column.  
    Dim Column        As ListColumn   '- This is for storing each table  
                                      '  column.  
    Dim Header        As String  
    Dim Index         As Long  
    Dim ValidItems    As Collection   '- This collection will be used to only  
                                      '  store valid data (non-empty)  

    Set BooksTable = ThisWorkbook.Worksheets("Books").ListObjects("Books")  
    
    For Each Column In BooksTable.ListColumns    
        Header = Column.Name   '- Extract the column header  
    
        Buffer = Column.DataBodyRange.Value   '- Extract the column data  
  
        'Loop through each row in the array and only add valid data to the  
        'collection  
        Set ValidData = New Collection  
  
        With ValidData  
            For Index = LBound(Buffer, 1) To UBound(Buffer, 1)  
                If IsValidData(Buffer(Index, 1) Then  
                    .Add Buffer(Index, 1)  
                End If  
            Next Index  
        End With  
  
        'Send header and data to email subroutine  
        EmailData Header, ValidData  
    Next Column  
End Sub  
  
'Function for validating whether the data is empty or null  
Private Function IsValidData(ByVal Data As Variant) As Boolean  
    If IsNull(Data) Then Exit Function  
    If IsEmpty(Data) Then Exit Function  
    If Data = vbNullString Then Exit Function  
  
    IsValidData = True  
End Function  
  
'Method for sending out emails.  
Private Sub EmailData(Header As String, ValidData As Collection)  
    'Define your email method here.  
End Sub  

Remove the On Error Resume Next after setting the range to catch other errors.

Option Explicit
Sub demo()

   Dim wsInscope As Worksheet, wsTeamData As Worksheet
   Dim rngInScope As Range, rngHeader As Range, rngCopy As Range
   Dim lastrow As Long, r As Long
   Dim team As String, emailaddress As String
   
   With ThisWorkbook
       Set wsInscope = .Sheets("In Scope")
       Set wsTeamData = .Sheets("TeamData")
   End With
   
   With wsInscope
       .AutoFilterMode = False
       lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
       Set rngInScope = .Range("A2:K" & lastrow)
       Set rngHeader = .Range("A1:R1")
   End With
   
   With wsTeamData
       lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
       For r = lastrow To 2 Step -1
            team = .Cells(r, 1)
            emailaddress = .Cells(r, 2)
            rngHeader.AutoFilter Field:=18, Criteria1:=team
            
            ' filter
            With rngInScope
                
                Set rngCopy = Nothing
                ' prevent error if no visible rows
                On Error Resume Next
                Set rngCopy = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                
                If rngCopy Is Nothing Then
                    ' no rows so skip
                    Debug.Print r, team, "skipped"
                Else
                
                    ' copy visible rows
                    rngCopy.Copy
                    Debug.Print r, team, rngCopy.Address
                
                End If
            End With
       Next
   End With
   ' clear clipboard and filters
   Application.CutCopyMode = False
   wsInscope.AutoFilterMode = False
   MsgBox "Complete"

End Sub

本文标签： excelVBA for checking empty cells below header after filteringStack Overflow