Range created from table with SpecialCells(xlCellTypeVisible) in Excel VBA gets extra row that are filtered

Question

I have a worksheet with a table with several data. I need to copy filtered data to a word document. First I've tried with.copy in excel and.pastespecial in word but after reading a lot during this last 4 days I started to work directly with objects because copy/paste procedure was slow and also it didn't get the results that I want.

With Object method I've found that when the range with specialCells(xCellTypeVisible) has multiple areas you need to look in every area to get the count of rows. But for some reason a row is added in Range but this row is not showed in Filter.

The code filters in a table Called "Horas" in a sheet called "Horas" by an string in Column A and an array on Column D (column D could have the following values V, W, X, Y and Z)

When filter by Column A and then filter by Array (X,Y and Z) some rows filtered with column A with values other than XY and Z are inside of Range and not filtered.

This is part of the code

'code to set word app, word doc and set XLSDoc objects, etc
    Set xlsSheet = xlsDoc.Worksheets("Horas")
    xlsSheet.Activate
    
    ' Clear AutoFilter
    For nCounter = 1 To xlsSheet.ListObjects("Horas").ListColumns.Count
        xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=nCounter
    Next
    
    ' Filter by customer and Row Type 
    xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=1, Criteria1:=customer
    xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=4, Criteria1:=Array("X", "Y", "Z"), Operator:=xlFilterValues
    
    ' calculate las row in table            
    Dim LR As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row - 1
    Dim rngFiltered As Range
    Set rngFiltered = Nothing
                   
    On Error Resume Next
    'define range with cells visible in table
    Set rngFiltered = Range("B2:G" & LR).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' check if range return values
    If Not rngFiltered Is Nothing Then
        Dim lcount
        Dim rngArea
    'check every area in range to get row count
        For Each rngArea In rngFiltered.SpecialCells(xlCellTypeVisible).Areas 
             lcount = lcount + rngArea.Rows.Count
        Next
        Dim i As Long
    'Add a row in word Table for every row in range filtered with visible cells
        For i = 1 To lcount
            HourTable.Rows.Add
            Set oRow = HourTable.Rows(HourTable.Rows.Count)
            Dim z As Long
            For z = 1 To 6
    'Copy every cell to word document
                 oRow.Cells(z).Range.Text = rngFiltered.Cells(i, z))
    Else
    'code to add a row if range is empty
        HourTable.Rows.Add
        Set oRow = HourTable.Rows(HourTable.Rows.Count)
        Dim mergeRNG As Word.Range
        Set mergeRNG = oRow.Cells(1).Range
        mergeRNG.End = oRow.Cells(HourTable.Columns.Count).Range.End
        mergeRNG.Cells.Merge
        HourTable.Cell(HourTable.Rows.Count, 1).Range.Text = "No se registraron horas en el período"
    End If

This code correctly filter by customer but when the customer has some rows with values other than XY and Z still appears in range and are copied to Word Table.

I think I have the same problem of this Thread but in this thread, data appears in the same area in continous rows. In my case, several rows are filtered when Column D filter is applied.

Thanks in advance for reading. Please forgive my english writing.

Answer 1

oRow.Cells(z).Range.Text = rngFiltered.Cells(i, z)

You can't access a multi-area (noncontiguous) range using an index like this.

To illustrate:

Sub Tester()

    Dim rngVis As Range, rw As Range, i As Long
    
    'rows 2:3 and 5 are hidden
    Set rngVis = ActiveSheet.Range("A1:C6").SpecialCells(xlCellTypeVisible)
    
    Debug.Print rngVis.Address(False, False)             '>> A1:C1,A4:C4,A6:C6
    
    Debug.Print rngVis.Cells(1, 1).Address(False, False) '>> A1
    Debug.Print rngVis.Cells(2, 1).Address(False, False) '>> A2 ! Cannot access range this way
    
    'loop rows like this, not using a counter.
    For Each rw In rngVis.Rows
        i = i + 1
        Debug.Print i, rw.Address(False, False)
    Next rw
    'Output:
    '1            A1:C1
    '2            A4:C4
    '3            A6:C6

End Sub