Not Pasting to Next Empty Row of ListObject Table

[Nadine]

Hi and thank you for any attention my post may receive.

I am copying data from a table (TblOut) on ws1 and pasting to TblExt on ws2 by calling this module from another module which pastes to the first row of TblExt.

The first module executes exaclty as planned, however the called module does not. It is pasting the correct data but not to the correct listrow in the databody of TblExt. It is pasting and leaving blank rows between the existing data and the pasted data. The number of blank rows is exactly the same number of rows as the data I am pasting.

If I execute my code again it leaves the existing blank rows plus that many again between.

I am rather perplexed as to how this is happening.

Sub OBoundToExtract()
Dim sarr, darr, arr As Variant, cac%, slr%, x%, i%, j%, k%, s As Worksheet
Dim tbl As ListObject, LastRow As Long
Dim rng As Range

  On Error Resume Next

  Set rng = Range("TblExt[[Extract]]").SpecialCells(xlCellTypeBlanks)

  On Error GoTo 0

  If Not rng Is Nothing Then
    rng.Delete Shift:=xlUp
  End If

Application.ScreenUpdating = False
On Error GoTo exitsub

Set s = Sheets("Outbound")
Set tbl = Sheets("Extract").ListObjects("TblExt")
LastRow = tbl.Range.Rows.Count
arr = Array(21, 20, 3, 22, 1, 1, 22)
cac = UBound(arr)
slr = s.Cells(Rows.Count, 23).End(xlUp).Row
x = Application.CountIf(s.Cells(1, 23).Resize(slr), "Y")
ReDim darr(x - 1, cac)
sarr = s.Cells(1, 1).Resize(slr, 23).Value
k = 0
    For i = 1 To slr
        If sarr(i, 23) = "Y" Then
            For j = 0 To cac
                darr(k, j) = sarr(i, arr(j))
            Next j
                k = k + 1
            Else
        End If
    Next i
Sheets("Extract").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Resize(k, cac + 1).Value = darr
Sheets("Extract").Protect
exitsub:
    Exit Sub
   
Application.EnableEvents = True
End Sub

 

[Nadine]

*** SOLVED ***

I have added this piece of code to my first module before calling the above module.

I am still unsure as to what the problem was but at least I can continue developing my workbook.

With Sheets("Extract").ListObjects("TblExt")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.ClearContents
            .DataBodyRange.Delete
        End If
    End With