Implementing Excel Business Applications using VBA and Open XML
This is a real-world scenario – you need to implement some sophisticated manipulation of Excel tables in VBA, and then you need to extract the data from the Open XML spreadsheet using the Open XML SDK. This screen-cast was based on a real-world project that I completed a short while ago. The customer wanted some slick behavior inside a spreadsheet. They wanted to automatically create tables, delete tables, and in some circumstances, to maintain the tables. After the data was as desired, then the user would save the macro-enabled workbook, and run an Open XML program that processed the data in an interesting way (that would be very difficult using VBA).
This screen-cast and example code are related to two other videos:
Using Open XML Package Editor to Create a Ribbon Button that runs a VBA Function
Using Open XML Package Editor to Customize Ribbon, Deploy as VBA Add-In
Code is attached.
For convenience, here is the VBA code listing, if you want to see the code that I show in the video without opening the XLSM and looking at the code in the VBA editor:
Private Sub btnClearTable1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If IsEmpty(Table1) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
Dim nbrRows As Integer
nbrRows = .Range.Rows.Count
.Range.Range("$A$2:$C$" & nbrRows).Delete
End With
End If
End Sub
Private Sub btnClearTable2_Click()
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If IsEmpty(Table2) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
Dim nbrRows As Integer
nbrRows = .Range.Rows.Count
.Range.Range("$A$2:$C$" & nbrRows).Delete
End With
End If
End Sub
Private Sub btnCopy1to2_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If IsEmpty(Table1) Then
MsgBox "Table 1 does not exist", vbOKOnly, "Error"
Else
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If IsEmpty(Table2) Then
MsgBox "Table 2 does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
nbrRows = .Range.Rows.Count
On Error Resume Next
.Range.Range("$A$2:$C$" & nbrRows).Delete
On Error GoTo 0
nbrRowsTable1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList").Range.Rows.Count
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList").Range.Range("$A$2:$C$" & nbrRowsTable1).Copy .Range.Range("$A$2").Resize(nbrRowsTable1 - 1, 3)
End With
End If
End If
End Sub
Private Sub btnCopy2to1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If IsEmpty(Table1) Then
MsgBox "Table 1 does not exist", vbOKOnly, "Error"
Else
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If IsEmpty(Table2) Then
MsgBox "Table 2 does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
nbrRows = .Range.Rows.Count
On Error Resume Next
.Range.Range("$A$2:$C$" & nbrRows).Delete
On Error GoTo 0
nbrRowsTable2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2").Range.Rows.Count
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2").Range.Range("$A$2:$C$" & nbrRowsTable2).Copy .Range.Range("$A$2").Resize(nbrRowsTable2 - 1, 3)
End With
End If
End If
End Sub
Private Sub btnCreateTable1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If Not IsEmpty(Table1) Then
MsgBox "Table already exists", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1")
.Cells(1, 1).Value = "Nbr"
.Cells(1, 2).Value = "Name"
.Cells(1, 3).Value = "Age"
.Cells(2, 1).Value = "1"
.Cells(2, 2).Value = "Eric"
.Cells(2, 3).Value = "50"
.Cells(3, 1).Value = "2"
.Cells(3, 2).Value = "Bob"
.Cells(3, 3).Value = "46"
.Cells(4, 1).Value = "4"
.Cells(4, 2).Value = "Jill"
.Cells(4, 3).Value = "34"
End With
ActiveWorkbook.Sheets("Sheet1").ListObjects.Add(xlSrcRange, _
ActiveWorkbook.Sheets("Sheet1").Range("$A$1:$C$4"), , xlYes).Name = _
"AgeList"
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList").TableStyle = "TableStyleLight2"
End If
End Sub
Private Sub btnCreateTable2_Click()
Dim StartingRow As Integer
StartingRow = 20
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If Not IsEmpty(Table2) Then
MsgBox "Table already exists", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").Range("$A$" & StartingRow)
.Cells(1, 1).Value = "Nbr"
.Cells(1, 2).Value = "Name"
.Cells(1, 3).Value = "Age"
.Cells(2, 1).Value = "6"
.Cells(2, 2).Value = "Autumn"
.Cells(2, 3).Value = "33"
.Cells(3, 1).Value = "7"
.Cells(3, 2).Value = "Joe"
.Cells(3, 3).Value = "56"
.Cells(4, 1).Value = "8"
.Cells(4, 2).Value = "Mary"
.Cells(4, 3).Value = "48"
End With
ActiveWorkbook.Sheets("Sheet1").ListObjects.Add(xlSrcRange, _
ActiveWorkbook.Sheets("Sheet1").Range("$A$" & StartingRow & ":$C$" & (StartingRow + 3)), , xlYes).Name = _
"AgeList2"
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2").TableStyle = "TableStyleLight2"
End If
End Sub
Private Sub btnDeleteRowTable1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If IsEmpty(Table1) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error Resume Next
.Range.Rows(2).Delete
On Error GoTo 0
End With
End If
End Sub
Private Sub btnDeleteRowTable2_Click()
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If IsEmpty(Table2) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
With ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error Resume Next
.Range.Rows(2).Delete
On Error GoTo 0
End With
End If
End Sub
Private Sub btnDeleteTable1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If Not IsEmpty(Table1) Then
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList").Delete
Else
MsgBox "Table does not exist", vbOKOnly, "Error"
End If
End Sub
Private Sub btnDeleteTable2_Click()
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If Not IsEmpty(Table2) Then
ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2").Delete
Else
MsgBox "Table does not exist", vbOKOnly, "Error"
End If
End Sub
Private Sub btnInsertRowTable1_Click()
On Error Resume Next
Table1 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList")
On Error GoTo 0
If IsEmpty(Table1) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
Dim newRow As ListRow
Set newRow = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList").ListRows.Add(AlwaysInsert:=True)
With newRow.Range
.Cells(1, 1).Value = 999
.Cells(1, 2).Value = "Bill"
.Cells(1, 3).Value = 11
End With
End If
End Sub
Private Sub btnInsertRowTable2_Click()
On Error Resume Next
Table2 = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2")
On Error GoTo 0
If IsEmpty(Table2) Then
MsgBox "Table does not exist", vbOKOnly, "Error"
Else
Dim newRow As ListRow
Set newRow = ActiveWorkbook.Sheets("Sheet1").ListObjects("AgeList2").ListRows.Add(AlwaysInsert:=True)
With newRow.Range
.Cells(1, 1).Value = 888
.Cells(1, 2).Value = "Aaron"
.Cells(1, 3).Value = 38
End With
End If
End Sub
Private Sub btnListAllData_Click()
Dim list As ListObject
Dim out As String
out = ""
For Each list In ActiveWorkbook.Sheets("Sheet1").ListObjects
out = out & "Table: " & list.Name & ": " & list.Range.Address & Chr(13)
Dim nbrRows As Integer
nbrRows = list.Range.Rows.Count
For i = 1 To nbrRows
out = out & list.ListColumns("Nbr").Range(i).Value & "|" & _
list.ListColumns("Name").Range(i).Value & "|" & _
list.ListColumns("Age").Range(i).Value & _
Chr(13)
Next i
Next
lblDisplay.Caption = out
End Sub
Private Sub btnListAllTables_Click()
Dim list As ListObject
Dim out As String
out = ""
For Each list In ActiveWorkbook.Sheets("Sheet1").ListObjects
out = out & "Table: " & list.Name & ": " & list.Range.Address & Chr(13)
Next
lblDisplay.Caption = out
End Sub
Download – Example Code