I have an issue that has been bugging me on and off for the last few days.
I have a worksheet with 100's of tables on, and a code that will insert more data onto that worksheet as it runs.
The idea is to then convert that added data to tables. However I run into a few problems with this.
I shall try and explain my current method, I have a for loop that can easily select the data in each of the current tables and the new data that has been added, using the .find method based upon i being Odd or Even. I then run down the spearsheet (as all the data is in the same column.) At this point I run into a world of trouble.
Firstly I tried to select the range of data that should be a table ( Sometimes it is, other it's not) and convert to table. This didnt work as I found out you are unable to force a table to become the same table again.
Secondly I tried to use On Errors to get around this. I tried to unlist the range as a table, then if there was an error i.e. the range was not a table then goto the section that makes the range a table, and if the Selected range was a table to then remove the table from the range and the re-format the range as a table.
At this point I was out of ideas. Below is my code for my second attempt.
If i Mod 2 = 0 Then ' This is to select the New Range '
j = j + 1 ' Used to name the tabels '
Set TableRange = Range(Cells(StartRow, 6), Cells(EndRow - 1, 13)) ' Selectst the table range '
TableRange.Select ' Selects the tabels '
On Error GoTo AddTable:
ActiveSheet.ListOnjects.Items(1).Unlist
AddTable:
ActiveSheet.ListObjects.Add(xlSrcRange, TableRange, , xlYes).Name = "Table" & j ' Formats the selected range as a table and names the table '
Range("Table" & j & "[#All]").Select ' Selects the table '
ActiveSheet.ListObjects("Table" & j).TableStyle = "TableStyleLight15" ' Sets the table style '
End If
I have tried to comment the code as best as possible as well as giving you a background into what my thought process was. I expect there are far simpler ways to do this, but not that I can think off.
Thanks for any help you can provide
Here is an example where ws.Range("A1:C8") is a table (the entire table including headers). Uses a function to return True if table else False
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim testRange As Range
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Set testRange = ws.Range("A1:C8")
If IsTable(testRange, ws) Then
Debug.Print "Table"
Else
End If
End Sub
Public Function IsTable(ByVal testRange As Range, ByVal ws As Worksheet) As Boolean
Dim table As ListObject
Dim tableAddresses() As String
ReDim tableAddresses(ws.ListObjects.Count)
Dim counter As Long
For Each table In ws.ListObjects
tableAddresses(counter) = table.Range.Address 'or databody range depending on your requirements
counter = counter + 1
Next table
Dim i As Long
For i = LBound(tableAddresses) To UBound(tableAddresses)
If testRange.Address = tableAddresses(i) Then
IsTable = True
Exit Function
End If
Next i
End Function
New data can be added to a ListObject using any of these two options:
Posting the new data in the next row immediately after the last row of the ListObject. The ListObject automatically resizes to include the new rows.
Resizing the Range of the ListObject to include the new rows. Note that when resizing a ListObject the Header must remain in the same row.
To validate if any Cell in a Range is part of a ListObject use the ListObject property of the range:
Set lo = rg.ListObject
I would also suggest declaring the variables and the use of Objects, so lines like this: ActiveSheet.ListOnjects.Items(1).Unlist would be written as: ws.ListOnjects.Items(1).Unlist. Then when compiling or running the procedures, spelling errors will be highlighted, given you the opportunity to do corrections such as: ws.ListObjects(1).Unlist. To force the declaration of variables and syntax check see fig. below.
As regards the Style of the ListObject you can set it by default for a workbook using this line:
wb.DefaultTableStyle = "TableStyleLight15" 'where wb is the workbook object
or it can be set when adding the ListObject as in:
ws.ListObjects.Add(xlSrcRange, rg, , xlYes, , "TableStyleLight15")
Try this procedure:
Sub Range_ListObject_Resizing()
Dim ws As Worksheet, rg As Range, lo As ListObject
Dim lRowIni As Long, lRowEnd As Long, i As Integer
Set ws = ActiveSheet
ws.Parent.DefaultTableStyle = "TableStyleLight15"
lRowIni = 3 'change as required
lRowEnd = 20 'change as required
If i Mod 2 = 0 Then
Rem Set Objects
Set rg = ws.Range(Cells(lRowIni, 6), Cells(lRowEnd - 1, 13))
Set lo = rg.ListObject
Rem Validate ListObject
If Not (lo Is Nothing) Then
lo.Resize rg
lo.TableStyle = "TableStyleLight15"
Else
Set lo = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
End If: End If
End Sub
Related
Little background, I am very new to VBA and just cant seem to find a solution to my problem. I am using this project as a means of learning basic VBA principles. Please bare with me.
I am currently attempting to write a macro that pulls values from non-contiguous cells (IE: F9, E15, G17, etc..) from a specific workbook and then pastes them into a table in a primary workbook. Each cell has data that needs to be added to a specific column in said table. I have hundreds of different files with the exact same layout (same important cell locations) that I want to eventually cycle through and add to a master table on the primary workbook. I would like to automate it.
My problem lies in not knowing the best method do go about this. I only need information from 12 cells per file so it is not an intense transfer. I have attempted going about it through arrays, creating variables, and messing with ranges. I was able to get to the point where I create a different variable for each cell I want data from and then, one-by-one, insert them into a specific cell in the primary workbook. This is far from automatic and doesn't include inserting each value under a specific column in my table.
Here is the most functional macro I've been able to create. It seems clunky and inefficient and does not prove to be a solution for my primary problems: automation, efficiency.
Sub data_pull()
Dim x As Workbook
Dim y As Workbook
Application.ScreenUpdating = False
Set x = Workbooks.Open("C:\Users\ - workbook that data is pulled from")
Set y = Workbooks.Open("C:\Users\ - workbook that data is put to")
'Pulling data through variables
RSS = x.Sheets(1).Range("F9").Value
RSE1_F = x.Sheets(1).Range("E13").Value
RSE1_B = x.Sheets(1).Range("F13").Value
RSE2_F = x.Sheets(1).Range("E14").Value
RSE2_B = x.Sheets(1).Range("F14").Value
TI = x.Sheets(1).Range("F20").Value
SI = x.Sheets(1).Range("F30").Value
FIBI = Split(x.Sheets(1).Range("F36").Value, "/") 'Cell has two values separated by a "/"
PEN = x.Sheets(1).Range("E40").Value
'Putting data through predefined variables
y.Sheets(1).Range("A1").Value = RSS
y.Sheets(1).Range("B1").Value = RSE1_F
y.Sheets(1).Range("C1").Value = RSE1_B
y.Sheets(1).Range("D1").Value = RSE2_F
y.Sheets(1).Range("E1").Value = RSE2_B
y.Sheets(1).Range("F1").Value = TI
y.Sheets(1).Range("G1").Value = SI
y.Sheets(1).Range("H1").Value = FIBI(0)
y.Sheets(1).Range("I1").Value = FIBI(1)
y.Sheets(1).Range("J1").Value = PEN
x.Close
Application.ScreenUpdating = True
End Sub
As you can see it is completely handled by calling for specific cell locations and does not append any data to a table specifically. I have a hunch that I could define a range with each cell location and then loop through that range, appending each cell to the desired table location.
Any and all feedback is greatly appreciated. If any more info is needed I am more than happy to elaborate!
Thanks!
One option for collecting cell values from a non-contiguous range is by defining the whole range, copying into an array and pasting in your uniform output region:
Option Explicit
Sub General_Testing()
' > Var
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim RG As Range
Dim CL As Range
Dim RGarr
Dim I As Long
' > Change to your workbooks/Sheets
Set wsInput = ThisWorkbook.Worksheets(1)
Set wsOutput = ThisWorkbook.Worksheets(2)
' > Source Data range
Set RG = wsInput.Range("$F$6,$E$13:$F$14,$F$20:$F$21")
ReDim RGarr(1 To RG.Cells.Count)
' > Move into array
I = 1
For Each CL In RG.Cells
RGarr(I) = CL.Value
I = I + 1
Next CL
With wsOutput
' > Array to output range
.Range("A1").Resize(1, UBound(RGarr)) = RGarr
' > last couple oddball values
.Range("H1:I1").Value = Split(wsInput.Range("F36"), "/")
.Range("J1").Value = wsInput.Range("F40").Value
End With
End Sub
If you want, you could easily do the whole thing including your split cell in the one array, just check for delimiter and increment I twice.
This is what is looks like:
Input:
Output:
Method 2:
Option Explicit
Sub General_Testing()
' > Var
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim RG As Range
Dim CL As Range
Dim RGarr
Dim I As Long
' > Change to your workbooks/Sheets
Set wsInput = ThisWorkbook.Worksheets(1)
Set wsOutput = ThisWorkbook.Worksheets(2)
' > Source Data range
Set RG = wsInput.Range("$F$6,$E$13:$F$14,$F$20:$F$21,$F$36,$E$40")
ReDim RGarr(1 To RG.Cells.Count)
' > Move into array
I = 1
For Each CL In RG.Cells
If InStr(1, CL.Value, "/") > 0 Then
' > String must be split
ReDim Preserve RGarr(1 To UBound(RGarr) + 1)
RGarr(I) = Split(CL.Value, "/")(0)
I = I + 1
RGarr(I) = Split(CL.Value, "/")(1)
I = I + 1
Else
' > String must not be split
RGarr(I) = CL.Value
I = I + 1
End If
Next CL
With wsOutput
' > Array to output range
.Range("A1").Resize(1, UBound(RGarr)) = RGarr
End With
End Sub
Background: I have a table in excel that data will get added to over time, and to give my coworkers (who, while lovely, do not like tinkering with things in excel in fear of messing something up) an easy option for expanding the table if it fills when I'm not around, I wanted to add a macro button to add more lines to the table and fill in the formatting (some cells have IF functions in & most have conditional formatting). The idea is they can fill up to but not including the last line of the table, then hit the button and it will add 20 or so new lines before the last line of table and copy the formatting of the last line into them.
So far this is my code:
Sub Add_Rows()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
x = tbl.Range.Rows.Count
Range(x - 1, x + 19).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
End Sub
I am getting a "Run time error '1004'" "Method range of object _global failed" message when I try clicking the button, and it highlights the "insert" line as being the issue. I am new to vba so any advice is welcome. If my code is utter nonsense then an alternative direction would be appreciated.
Also this is the second version, my first looped Rows.Add which worked, but was taking a few seconds so my hope was inserting 20 would be faster than adding 1 20 times!
Try this.
Sub Add_Rows()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Dim lastRow As Range, newRng As Range
Dim newRows As Integer: newRows = 20
Set tbl = ws.ListObjects("Table1")
' Last row
On Error GoTo resizeOnly ' Listrows = 0
Set lastRow = tbl.ListRows(tbl.ListRows.Count).Range
On Error GoTo 0
' range of new rows
Set newRng = tbl.ListRows(tbl.ListRows.Count).Range.Resize(newRows).Offset(1)
' resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + newRows, tbl.Range.Columns.Count)
' copy last format to new rows
lastRow.Copy
newRng.PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Exit Sub
resizeOnly:
' resize table
tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + newRows, tbl.Range.Columns.Count)
End Sub
If you have no data below the table, you can just assign values to the rows immediately after the table. The table will automatically expand to encompass the new rows, as long as at least one cell in each row, has well defined data.
' Insert 3 new rows into the listoject
' We assume the ListObject already contains data
Public Sub Test(Lob As ListObject)
Dim Sht As Worksheet
Dim StartRow As Long, StartCol As Long, NumCols As Long
Dim Lst As Variant
Dim Rng As Range
' Allocate 3 new rows
NumCols = Lob.ListColumns.Count
ReDim Lst(1 to 3, 1 to NumCols)
' Get the first column of and the first row following the list table
StartCol = Lob.Range.Column
StartRow = Lob.Range.row + Lob.Range.Rows.Count
' Create a range big enough to hold the data, immediately under the last row of the table.
Set Sht = Lob.Parent
Set Rng = Sht.Cells(StartRow, StartCol).Resize(UBound(Lst), UBound(Lst, 2))
' Add some data to the new rows
Lst(1, 1) = "Test1"
Lst(2, 1) = "Test2"
Lst(3, 1) = "Test3"
' Copy data to the destination
Rng = Lst
End Sub
If the list object does not contain data, ie Lob.ListRows.Count = 0, then write data after the header otherwise write it after the last rows.
There are some mistakes in your code:
"Range(x , y)" will cause an error, when x and y are integers. If you want to refer to a cell. Try Cells(x, y). Or Range(Cells(x1, y1), Cells(x2, y2)) to refer to more cells.
And Resize() takes two arguments, and returns a range - it does not affect anything on the sheet.
See also how to insert rows if you want:
Excel Range.Insert:
Example from the doc:
With Range("B2:E5")
.Insert xlShiftDown
' Optionally clear formats, which you do not want, if you add to
' a table with well defined data and formats.
.ClearFormats
End With
The number of the rows inserted, will equal the number of rows in the range we call Insert on.
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
In one of my worksheets, I have a
Private Sub BuggingVba()
That should replace the data in a table with an array of values
Dim MyTable As ListObject, myData() As Variant
Set MyTable = Me.ListObjects(1)
myData = collectMyData ' a function defined somewhere else in my workbook
It is probably irrelevant, but before doing so, I resize the list object (I expand line by line because if I do it at once, I overwrite what is below my table instead of schifting it.)
Dim current As Integer, required As Integer, saldo As Integer
current = MyTable.DataBodyRange.Rows.Count
required = UBound(sourceData, 1) - LBound(sourceData, 1)
' current and required are size of the body, excluding the header
saldo = required - current
If required < current Then
' reduce size
Range(DestinBody.Rows(1), DestinBody.Rows(current - required)).Delete xlShiftUp
Else
' expland size
DestinBody.Rows(1).Copy
For current = current To required - 1
DestinBody.Rows(2).Insert xlShiftDown
Next saldo
End If
If there is any data to insert, I overwrite the values
If required Then
Dim FullTableRange As Range
Set FullTableRange = MyTable.HeaderRowRange _
.Resize(1 + required, MyTable.HeaderRowRange.Columns.Count)
FullTableRange.Value = sourceData
End If
And BAM, my table/ListObject is gone! Why does this happen and how can I avoid it?
End Sub
When we paste over the entire table or clear the contents of the entire table the collateral result is that the table object (ListObject) is deleted. That’s the reason the code works when the data is changed row by row.
However, there is no need to do it row by row, not even the insertion of new rows if we work with the properties of the ListObject as demonstrated in the code below.
In these procedures we assumed that the "Target" Table and the “New Data” are, in the same workbook holding the code, located at worksheets 1 and 2 respectively:
As we will work with the HeaderRowRange and the DataBodyRange of the ListObject then we need to obtain the “New Data” to replace the data in the table in the same manner. The code below will generate two arrays with the Header and Body Arrays.
Sub Dta_Array_Set(vDtaHdr() As Variant, vDtaBdy() As Variant)
Dim vArray As Variant
With ThisWorkbook.Worksheets("Sht(1)").Range("DATA") 'Change as required
vArray = .Rows(1)
vDtaHdr = vArray
vArray = .Offset(1, 0).Resize(-1 + .Rows.Count)
vDtaBdy = vArray
End With
End Sub
Then use this code to replace the data in the table with the "New Data"
Private Sub ListObject_ReplaceData()
Dim MyTable As ListObject
Dim vDtaHdr() As Variant, vDtaBdy() As Variant
Dim lRowsAdj As Long
Set MyTable = ThisWorkbook.Worksheets(1).ListObjects(1) 'Change as required
Call Data_Array_Set(vDtaHdr, vDtaBdy)
With MyTable.DataBodyRange
Rem Get Number of Rows to Adjust
lRowsAdj = 1 + UBound(vDtaBdy, 1) - LBound(vDtaBdy, 1) - .Rows.Count
Rem Resize ListObject
If lRowsAdj < 0 Then
Rem Delete Rows
.Rows(1).Resize(Abs(lRowsAdj)).Delete xlShiftUp
ElseIf lRowsAdj > 0 Then
Rem Insert Rows
.Rows(1).Resize(lRowsAdj).Insert Shift:=xlDown
End If: End With
Rem Overwrite Table with New Data
MyTable.HeaderRowRange.Value = vDtaHdr
MyTable.DataBodyRange.Value = vDtaBdy
End Sub
Old post, but the way I paste over a listobject table is to delete the databodyrange, set a range to the array size and then set the range to the array. Similar to the solution provided above, but doesn't require resizing the table.
'Delete the rows in the table
If lo.ListRows.Count > 0 Then
lo.DataBodyRange.Delete
End If
'Assign the range to the array size then assign the array values to the range
Set rTarget = wsTemplate.Range("A2:K" & UBound(arrTarget) + 1)
rTarget = arrTarget
I have a sheet that contains a table (produced from jasper report query). This table will be the source of my pivot table. The Pivot is created using an external connection (From Microsoft Query). since the source table needs to be defined before it can be used in Micrososft Query, could anyone show me how to do it programatically?
INFO:
There are 2 documents here, the first is a protected source data and the second is a Pivot document.
The data is dynamic and the table contains a header.
Is there any way to define the table area using excel programatically with dynamic data?
To answer your comments from the two previous answers (whose, in my opinion, fit your need).
Here is a way to define named range with vba:
Dim Rng1 As Range
'Change the range of cells (A1:B15) to be the range of cells you want to define
Set Rng1 = Sheets("Sheet1").Range("A1:B15")
ActiveWorkbook.Names.Add Name:="MyRange", RefersTo:=Rng1
Source
Here is a way to create a table with vba (remember it will only work on Excel 2007 or higher):
Sub CreateTable()
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$1:$D$16"), , xlYes).Name = _
"Table1"
'No go in 2003
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight2"
End Sub
Source
If you use a table (defined) , you can call table object sample
Sub DefineTable()
Dim tbl As ListObject
Set tbl = Sheets("Plan1").ListObjects(1)
tbl.Range.Select
End Sub
Otherwise is create a dynamic range using a name for example
=OFFSET(Plan1!A1;0;0;counta(Plan1!A:A);counta(Plan1!1:1))
Select a name to this range, and in your pivot define a range at =NameOfInterval
[]'s
Public Function CopyDist() As Variant
On Error Resume Next
CopyDist = 0
' RemoveTableStyle
Dim oSh As Worksheet
Set oSh = ActiveSheet
' Set oSh = 'Sheets("Sheet1")
Dim oNewRow As ListRow
Dim myfirstrow As Integer
Dim mylastrow As Integer
Dim myfirstcolumn As Integer
Dim myValue As Variant
myfirstrow = ActiveCell.Row + 1
mylastrow = ActiveCell.Row + 1
myfirstcolumn = ActiveCell.Column
Cells(myfirstrow, myfirstcolumn).Select
Cells(myfirstrow, myfirstcolumn).Clear
oSh.Range("$A$1:$D$16").Select
oSh.ListObjects.Add(xlSrcRange, oSh.Range("$A$1:$D$16"), , xlYes).Name = "Table1"
'No go in 2003
oSh.ListObjects("Table1").TableStyle = "TableStyleLight2"
' CreateTable
If oSh.ListObjects.Count > 0 Then
myValue =oSh.ListObjects.Count
End If
RemoveTableStyle
CopyDist = 1
End Function
Here's how to approach if you do not know the range size: First get the index refs of the last row / column. Then use the indexes to create "Table1"
Dim lngLastColumn as Long
Dim lngLastRow as Long
Set oxlSheet = oxlWB.Worksheets(1) '''or whichever sheet you need
With oXlSheet
lngLastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.ListObjects.Add(xlSrcRange, .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastColumn)), , xlYes).Name = "Table1"
End With