Delete only table data using VBA

[craig2525]

Hi all. I have a sheet that I need to clear the contents of a table but not the entire sheet. The table is in columns B through U. I have other data in the sheet that I do not want to delete. They are in columns AA through AN. I have tried protecting the cells but I get and error when doing this. Here is the code I am using.

 

[NoSparks]

Here's a couple links to pages dealing with tables that may be of interest to you

The VBA Guide To ListObject Excel Tables

For a data analyst, Excel Tables are a necessity! They are the most efficient way to organize your raw data and refer to data that contracts or expands on a regular basis. Likewise, Excel tables can be extremely useful in combination with VBA.

www.thespreadsheetguru.com

Excel: Working with Tables (VBA)

jkp-ads.com: Excel Tables (VBA)

jkp-ads.com

 

[Alex Blakenburg]

I was going to suggest changing your delete line to this:-

.DataBodyRange.Rows.Delete

But even your code only deletes the rows in the table and does not impact the rows to the right outside the table.

What is the actual issue ?

 

[craig2525]

With this code (originally posted), it was deleting data outside the table.

 

[craig2525]

Sub clearTable()

With toSched.ListObjects("ToScheduleTbl")
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.ClearContents

End If
End With

End Sub

I tried this and it didn't delete the other data outside the table but wiped out the formulas in the table.

 

[Alex Blakenburg]

With the clear contents approach you need to add xlCellTypeConstants into the mix and then a resize table.
I am not finding the need to go through all that trouble though.

With this code I am getting the results in the picture below.
Obviously if I have rows out the side that reference the rows being deleted they will change to #REF!

If it doesn't work for you perhaps you can give a us a sample workbook via a sharing platform to test on.

Sub testdelete()
    Dim sht As Worksheet
    Dim tbl As ListObject
    
    Set sht = ActiveSheet
    Set tbl = sht.ListObjects("ToScheduleTbl")

    tbl.DataBodyRange.Delete
End Sub

 

[craig2525]

How do I use the sharing platform?

 

[Alex Blakenburg]

Do you use Dropbox, OneDrive, GoogleDrive or any other sharing mechanism ?
Put a copy of your s/sheet there without any confidential data and then share it as public to anyone with the link and then post the link here.

If you want to try using XL2BB first then we could do that, given the nature of your issue I am just not sure that it will come through using that method.

 

[craig2525]

Schedule Tool.xlsm
	A	B	C	D	E	F	G				K	L	M	N	O	P	Q				U	V	W	X	Y
1
2		WO NO	Org	Equipment	EQUIPMENT DESC	PM Code	PM DESC				1 WO Owner	2 Sched Block	3 Shift	4 Supervisor	Sched Start Date	Sched End Date	5 Planned				Tech Labor
4		64196589	AAA	PCK	PACKER	A2	PACKER				SHAWN				12/31/2021	12/31/2021	+				0.00
5		64196590	AAA	RCV	RECEIVE	A3	RECEIVE				JOHN				12/31/2021	12/31/2021	+				0.00
6		64196592	AAA	SHP	SHIPPER	A4	SHIPPER				BRIAN				12/31/2021	12/31/2021	+				0.00
7		64196594	AAA	SHP	SHIPPER	A5	SHIPPER				BRIAN				12/31/2021	12/31/2021	+				0.00
8		64196596	AAA	SHP	SHIPPER	A6	SHIPPER				JOHN				12/31/2021	12/31/2021	+				0.00
9		64196598	AAA	1000086692	AUGER	A7	AUGER				BRIAN				12/31/2021	12/31/2021	+				0.00
10		64196599	AAA	1000086801	AUGER	A8	AUGER				BRIAN				12/31/2021	12/31/2021	+				0.00		12/3/2021	12/4/2021	12/5/2021
11		64196600	AAA	1000086189	COMPRESSOR	A9	COMPRESSOR				BRIAN				12/31/2021	12/31/2021	+				0.00		Friday	Saturday	Sunday
12		64196601	AAA	1000086190	COMPRESSOR	A10	COMPRESSOR				BRIAN				12/31/2021	12/31/2021	+				0.00		KEVIN	KEN	PAM
13		64196602	AAA	1000086191	BOX MACHINE	A11	BOX MACHINE				SHAWN				12/31/2021	12/31/2021	+				0.00		SAM	BRIAN	JILL
14		64196603	AAA	1000086192	BOX MACHINE	A12	BOX MACHINE				SHAWN				12/31/2021	12/31/2021	+				0.00		MIKE	NATE	ANGIE
15		64196785	AAA	PCK	PACKER	A13	PACKER				SHAWN				12/31/2021	12/31/2021	+				0.00
16		64196786	AAA	PCK	PACKER	A14	PACKER				SHAWN				12/31/2021	12/31/2021	+				0.00
17		64196788	AAA	RCV	RECEIVE	A15	RECEIVE				JOHN				12/31/2021	12/31/2021	+				0.00
18		64196791	AAA	SHP	SHIPPER	A16	SHIPPER				JOHN				12/31/2021	12/31/2021	+				0.00
19		64196793	AAA	SHP	SHIPPER	A17	SHIPPER				JOHN				12/31/2021	12/31/2021	+				0.00
20		64196794	AAA	SHP	SHIPPER	A18	SHIPPER				BRIAN				12/31/2021	12/31/2021	+				0.00
21		64196795	AAA	B.ENCLOSURE.137	Enclosure	A19	Enclosure				KEVIN				12/31/2021	12/31/2021	+				0.00
22		64196796	AAA	C.INTERIOR.137	Construction	A20	Construction				KEVIN				12/31/2021	12/31/2021	+				0.00
23		64196797	AAA	FLS.FAS	FIRE ALARM	A21	FIRE ALARM				KEVIN				12/31/2021	12/31/2021	+				0.00
24		64196838	AAA	1000085910	COMPRESSOR	A22	COMPRESSOR				BRIAN				12/31/2021	12/31/2021	+				0.00
25		64196903	AAA	A100002	COMPRESSOR	A23	COMPRESSOR				TIM				12/31/2021	12/31/2021	+				0.00
26		64197125	AAA	1000086988	AUGER	A24	AUGER				SHAWN				12/31/2021	12/31/2021	+				0.00
27		64197126	AAA	1000086120	AUGER	A25	AUGER				SHAWN				12/31/2021	12/31/2021	+				0.00
28		64197127	AAA	1000086122	AUGER	A26	AUGER				JOHN				12/31/2021	12/31/2021	+				0.00
29		64197128	AAA	1000086121	AUGER	A27	AUGER				JOHN				12/31/2021	12/31/2021	+				0.00
30		64234621	AAA	PCK	PACKER	A27	PACKER				BRIAN				1/1/2022	1/1/2022	+				0.00
31		64234622	AAA	PCK	PACKER	A29	PACKER				BRIAN				1/1/2022	1/1/2022	+				0.00
"TO SCHEDULE" DOWNLOAD

Cell Formulas
Range	Formula
L4:L31	L4	=IFERROR(INDEX(#REF!,MATCH([@[Unique Code (Do Not Transfer to Upload Template)]],#REF!,0)),"")
M4:N31	M4	=IFERROR(INDEX(#REF!,MATCH([@[1 WO Owner]],#REF!,0)),"")
U4:U31	U4	=SUMIFS([AVG LABOR FOR PM,EQUIP, AND ORG],[1 WO Owner],[@[1 WO Owner]],[Sched Start Date],[@[Sched Start Date]])

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING SORTER/INDUCT/RECIRC STROBE FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING SORTER/INDUCT/RECIRC STROBE BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING SORTER/ INDUCT/ RECIRC DAILY PM"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING LANE STROBE FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING LANE STROBE BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING LANE DAILY PM"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING COLLECTORS STROBE FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING COLLECTORS STROBE BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT SHIPPING COLLECTOR DAILY PM"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT RECEIVE STROBE FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT RECEIVE STROBE BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT RECEIVE DAILY"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANES STROBE 2/2 FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANES STROBE 1/2 FRONT HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANES STROBE 2/2 BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANES STROBE 1/2 BACK HALF"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANE 2/2 DAILY"	text	NO
G:G	Cell Value	contains "TRADITIONAL NON-SORT PACK LANE 1/2 DAILY"	text	NO

Cells with Data Validation
Cell	Allow	Criteria
K4:K31	List	=TECH_LOGIN_LIST

 

[craig2525]

Function findFilePath()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select a file."
.Filters.Clear
.Filters.Add "All Files", "*.*"
If .Show = True Then
findFilePath = .SelectedItems(1)
End If
End With
End Function
Private Function findConnStr(fileEx As String, filePath As String)
Select Case fileEx

Case "xlsx"
findConnStr = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & filePath & ";" & _
"Extended Properties='Excel 12.0 Xml;" & _
"HDR=YES';"

Case "xlsm"
findConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & filePath & ";" & _
"Extended Properties='Excel 12.0 Macro;HDR=YES';"

End Select
End Function
Sub ImportEAMexport()
Dim filePath As String: filePath = findFilePath
If filePath = "" Then Exit Sub
Dim fileEx As String: fileEx = Right(filePath, Len(filePath) - InStrRev(filePath, "."))
Dim shtName As String
Dim cFile As ADODB.Connection
Dim rs As ADODB.Recordset
Set cFile = New ADODB.Connection

Select Case fileEx

Case "csv"
nameFile = Dir(filePath)
filePathLoc = Left(filePath, InStrRev(filePath, "\"))
cFile.ConnectionString = "Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & filePathLoc & ";Extensions=asc,csv,tab,txt;"

cFile.Open

Set rs = New ADODB.Recordset
With rs
.ActiveConnection = cFile
.Source = "SELECT * FROM [" & nameFile & "]"
.Open
End With


Case Else
cFile.ConnectionString = findConnStr(fileEx, filePath)

cFile.Open
upload_frm.sht_list.Clear
Set rsSht = cFile.OpenSchema(adSchemaTables)
Do While Not rsSht.EOF
upload_frm.sht_list.AddItem rsSht.Fields("TABLE_NAME").Value
rsSht.MoveNext
Loop
rsSht.Close

If upload_frm.sht_list.ListCount > 1 Then
upload_frm.Show
shtName = upload_frm.selsht
Else
shtName = upload_frm.sht_list.List(0)
End If

Set rs = New ADODB.Recordset
On Error GoTo rsError
With rs
.ActiveConnection = cFile
.Source = "SELECT [Work Order], [Organization], [Equipment], [Equipment Description], [PM Code], [Description], 'R',[Department], 'V', [1 - WO Owner], '', '', '', [Sched# Start Date], [Sched# End Date], '+', '+' FROM [" & shtName & "]"
.Open
End With
On Error GoTo 0

End Select

clearTable

toSched.Range("B3").CopyFromRecordset rs

rs.Close
cFile.Close


schedblock = "=IFERROR(INDEX(SCHED_BLOCK[2 Sched Block],MATCH([@[Unique Code (Do Not Transfer to Upload Template)]],SCHED_BLOCK[Unique Code (autofill)],0)),"""")"
shift = "=IFERROR(INDEX(TECH_INFO[SHIFT CODE],MATCH([@[1 WO Owner]],TECH_INFO[TECH LOGIN],0)),"""")"
super = "=IFERROR(INDEX(TECH_INFO[SUPERVISOR],MATCH([@[1 WO Owner]],TECH_INFO[TECH LOGIN],0)),"""")"
lbr = "=IFERROR(INDEX(SCHED_BLOCK[AVG LABOR FOR PM,EQUIP, AND ORG],MATCH([@[Unique Code (Do Not Transfer to Upload Template)]],SCHED_BLOCK[Unique Code (autofill)],0)),"""")"
Unicode = "=CONCATENATE([Equipment],""."",[PM Code])"

Range("l3") = schedblock
Range("m3") = shift
Range("n3") = super
Range("s3") = lbr
Range("t3") = Unicode
Exit Sub

rsError:
MsgBox "Could not import selected sheet. Check if selected sheet has the correct layout items and try again."

End Sub

Sub clearTable()

With toSched.ListObjects("ToScheduleTbl")
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.Delete
End If
End With

End Sub