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