Remove blank cell from bottom of table

[5foot9]

I have a set of tables that are linked to powerpivot. The one table I'm having trouble with either increases or decreases in size each day and only has one column. Because of the daily changes in size it leaves a blank cell at the bottom of the table causing powerpivot to throw an error at me when I try to update it.

I've tried a few different ways and the last one below is the one where I think I'm heading in the right direction but as a novice I'm getting very bogged down with it and would really appreciate some help if its possibble.

[Sub Today()

Dim lastrow As Long
Dim rng As Range
Dim tbl As ListObject


Set tbl = ThisWorkbook.Sheets("Tables").ListObjects("TodayQ")

Application.ScreenUpdating = False

'clears previous days table
Sheets("Tables").Select
If tbl.ListRows.Count >= 1 Then
tbl.DataBodyRange.Delete
End If

'collects key numbers from daily list (can contain duplicates)
'places in new sheet and removes duplicates
Sheets("Qualifiers").Select
Range("L2:L101").Select
Selection.Copy
Sheets("Tables").Select
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Range("R2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("TodayQ[#All]").RemoveDuplicates Columns:=1, Header:= _
xlYes
'attempts to remove blank cell at bottom of table by resizing table
lastrow = ActiveSheet.ListObjects("TodayQ").Range.Rows.Count
Set rng = Range("TodayQ[#All]").Resize(lastrow, 1)
ActiveSheet.ListObjects("TodayQ").Resize rng

Application.ScreenUpdating = True


End Sub]

 

[Jeffrey Mahoney]

I don't know if this will actually do what you need, but without your data, I can't try alternatives.

Sub Today()

  Dim lastrow As Long
  Dim rng As Range
  Dim tbl As ListObject
  [COLOR=#ff0000]Dim Cel As Range[/COLOR]
  
  Set tbl = ThisWorkbook.Sheets("Tables").ListObjects("TodayQ")
  
  Application.ScreenUpdating = False
  
  'clears previous days table
  Sheets("Tables").Select
  If tbl.ListRows.Count >= 1 Then
    tbl.DataBodyRange.Delete
    [COLOR=#ff0000]Set Cel = Cells(Cells.Rows.Count, tbl.Resize(1, 1).Column).End(xlUp)
    If Len(Cel.Value) = 0 And Application.isblank(Cel) = False Then
      Cel.EntireRow.Delete
    End If[/COLOR]
  End If
  
  'collects key numbers from daily list (can contain duplicates)
  'places in new sheet and removes duplicates
  Sheets("Qualifiers").Select
  Range("L2:L101").Select
  Selection.Copy
  Sheets("Tables").Select
  Range("M2").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Application.CutCopyMode = False
  Selection.Copy
  Range("R2").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Application.CutCopyMode = False
  ActiveSheet.Range("TodayQ[#All]").RemoveDuplicates Columns:=1, Header:= _
  xlYes
  'attempts to remove blank cell at bottom of table by resizing table
  lastrow = ActiveSheet.ListObjects("TodayQ").Range.Rows.Count
  Set rng = Range("TodayQ[#All]").Resize(lastrow, 1)
  ActiveSheet.ListObjects("TodayQ").Resize rng
  
  Application.ScreenUpdating = True
  
End Sub

 

[5foot9]

Thanks Jeffrey, I'm not back til this evening so will try your suggestion then.

 

[Trebor76]

Note this has been cross-posted here.

 

[5foot9]

Sorry for forgetting the link to the other post, here it is - Remove blank cell from bottom of table

 

[5foot9]

Jeffrey - Just tried it and it produced a type mismatch error - Resize(1, 1), if I change 1 to lastrow it gives the same. Lets see if I can explain myself better in what I'm trying to do. I have several tables linked to a data model. I have different job numbers arrive each day some are duplicates, this code is intended firstly to clear the previous days contents in table 'TodayQ' then collect the new jobs from another sheet and paste it on the same sheet as 'TodayQ', then remove duplicates entering the resulting list to 'TableQ'.


'TableQ' is the only table that can reduce or increase in size. For some reason this makes excel add a blank cell at the bottom of the table each time it changes whereas all the other tables in the workbook don't, they all update in the data model without problems. I have tried deleting the last row, but sometimes when a larger than previous amount of data is added there is no blank cell resulting in the last row of data being deleted.


I did think about converting the table to a range then back to a table but I think that may confuse the hell out of powerpivots data model.

 

[5foot9]

I have what I want now, its a bit round the houses and requires manual input if there is an error but I'm ok with that...it works fine, thanks for the help and I must remember to post a link if I cross post! sorry.

[Sub Today()

Dim newsize As Long
Dim rng As Range
Dim tbl As ListObject


Set tbl = ThisWorkbook.Sheets("Tables").ListObjects("TodayQ")

Application.ScreenUpdating = False

'clears previous days table
Sheets("Tables").Select
If tbl.ListRows.Count >= 1 Then
tbl.DataBodyRange.delete
End If

'collects key numbers from daily list (can contain duplicates)
'places in new sheet and removes duplicates
Sheets("Qualifiers").Select
Range("L2:L101").Select
Selection.Copy
Sheets("Tables").Select
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Range("R2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("TodayQ[#All]").RemoveDuplicates Columns:=1, Header:= _
xlYes

'removes blank cell at bottom of table by resizing table

newsize = ActiveSheet.Range("P1").Value
Set rng = Range("TodayQ[#All]").Resize(newsize, 1)
ActiveSheet.ListObjects("TodayQ").Resize rng

'creates a helper column to check no values are accidently removed by resizing
' I have a cell that tells me true or false

Columns("T:T").Select
Selection.ClearContents
Range("T1").Select
ActiveCell.FormulaR1C1 = "Slot check"
Range("T2").Select
Range("M2:M101").Select
Selection.Copy
Range("T2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$T$2:$T$101").RemoveDuplicates Columns:=1, Header:=xlNo


Application.ScreenUpdating = True


End Sub]