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