Not Pasting to Next Empty Row of ListObject Table

Nadine

New Member
Joined
May 12, 2020
Messages
32
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
*** 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.

Code:
With Sheets("Extract").ListObjects("TblExt")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.ClearContents
            .DataBodyRange.Delete
        End If
    End With
 
Upvote 0
Solution

Forum statistics

Threads
1,213,496
Messages
6,113,993
Members
448,539
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top