Creating new table from existing excel sheet in vb

Question

I have an excel sheet with many columns and an unknown number of rows. I'm trying to write a VB macro to dynamically convert the data from a few selected columns and all rows into a table.

I'm running into some syntaxt issues. Everything I find says to use the As syntax. For example:

Dim workRow As DataRow = table.NewRow()

or

Dim table As New DataTable

But whenever I do this I get an error Expected: End of statement

Here is my code:

Sub CreateTable()
    FinalRow = Cells(Rows.Count, 6).End(xlUp).Row
    
    Dim table
    table = DataTable("TotOpenOI")
    Dim strike
    strike = DataColumn("Strike", GetType(Int32))
    Dim expiry
    expiry = DataColumn("Expiry", GetType(DateTime))
    Dim callDelta
    callDelta = DataColumn("Call Delta", GetType(Int32))
    Dim putDelta
    putDelta = DataColumn("Put Delta", GetType(Int32))
    
    Dim tableRow
    
    For i = 6 To FinalRow
        tableRow = DataRow.NewRow()
        tableRow(0) = strike
        tableRow(1) = expiry
        tableRow(2) = callDelta
        tableRow(3) = putDelta
        table.Rows.Add (tableRow)
    Next
End Sub

I want to create a new table with the columns: strike, expiry, callDelta, PutDelta and use every row from 1 to last -- starts at row 6.

Note: I'm only using those 4 columns but there are 20 or so columns in my spreadsheet.

Thank you.

My goal is to create a pivot table out of the columns I highlighted in my original question. The data I'm pulling in has a lot of columns I don't need and the API doesn't allow me to remove columns in the query. So I want to create a new, more condensed table out of the data to then use to create a pivot table. I added a screen shot of the chart I'm creating from the selected data.

Answer 1

Export Columns to a New Excel Table

• The following will delete the destination worksheet and add a new one!

Sub ExportColumnsToNewTable()

    ' Define constants.
    Const PROC_TITLE As String = "Export Columns to a New Excel Table"
    Const SRC_SHEET_NAME As String = "Sheet1"
    Const SRC_HEADER_ROW As Long = 6
    Const DST_SHEET_NAME As String = "Sheet2"
    Const DST_TABLE_NAME As String = "StrikeExpiry"
    Const DST_FIRST_CELL As String = "A1"
    Dim Headers() As Variant:
    Headers = VBA.Array("Strike", "Expiry", "CallDelta", "PutDelta")
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range ('srg').
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim cCount As Long: cCount = UBound(Headers) + 1 ' zero-based
    Dim srg As Range
    With sws.UsedRange
        Dim sfcell As Range: Set sfcell = sws.Cells(SRC_HEADER_ROW, .Column)
        Dim slcell As Range: Set slcell = .Cells(.Cells.CountLarge)
        If slcell.Row - sfcell.Row < 1 Then ' headers (+1)
            MsgBox "Not enough rows of data found!", _
                vbInformation, PROC_TITLE
            Exit Sub
        End If
        If slcell.Column - sfcell.Column + 1 < cCount Then
            MsgBox "Not enough columns of data found!", _
                vbInformation, PROC_TITLE
            Exit Sub
        End If
        Set srg = sws.Range(sfcell, slcell)
    End With
       
    ' Retrieve the source column indexes ('scIndexes').
    Dim scIndexes() As Variant:
    scIndexes = Application.Match(Headers, srg.Rows(1), 0)
    Dim c As Long
    If Application.Count(scIndexes) < cCount Then
        Dim iMsg As String
        For c = 1 To cCount
            If IsError(scIndexes(c)) Then
                iMsg = iMsg & vbLf & Headers(c - 1)
            End If
        Next c
        iMsg = "The following headers could not be found: " & vbLf & iMsg
        MsgBox iMsg, vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    ' Write the values from the source range to the source array ('sData').
    Dim sData() As Variant: sData = srg.Value
    
    ' Define the destination array ('dData').
    Dim rCount As Long: rCount = UBound(sData, 1)
    Dim dData() As Variant: ReDim dData(1 To rCount, 1 To cCount)

    ' Write the values from the designated columns of the source array
    ' to the destination array.
    Dim r As Long, sc As Long
    For c = 1 To cCount
        sc = scIndexes(c)
        For r = 1 To rCount
            dData(r, c) = sData(r, sc)
        Next r
    Next c

    Application.ScreenUpdating = False

    ' Delete the destination sheet.
    Dim dsh As Object:
    On Error Resume Next
        Set dsh = wb.Sheets(DST_SHEET_NAME)
    On Error GoTo 0
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False ' delete without confirmation
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Add a new (destination) worksheet.
    Dim dws As Worksheet:
    Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    dws.Name = DST_SHEET_NAME
    
    ' Write the values from the destination array to the destination range.
    Dim dfcell As Range: Set dfcell = dws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfcell.Resize(rCount, cCount)
    drg.Value = dData
    
    ' Convert the destination range to a table.
    Dim dlo As ListObject:
    Set dlo = dws.ListObjects.Add(xlSrcRange, drg, , xlYes)
    On Error Resume Next
        dlo.Name = DST_TABLE_NAME
    On Error GoTo 0
    drg.EntireColumn.AutoFit
    ' or dlo.Range.EntireColumn.AutoFit
    
    ' Additional Ideas:
    'sws.Activate
    'wb.Save
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Columns exported to table """ & dlo.Name _
        & """ in worksheet """ & DST_SHEET_NAME & """.", _
        vbInformation, PROC_TITLE

End Sub

Answer 2

It's very hard to understand what you finally need. In this situation I can recommend you three simple steps which follow you to success:

1. Proceed all actions manually to get the correct result.
2. Repeat and record your actions (Developers-->Record Macro).
3. Adjust the code.

Answer 3

First find the last row of your data - there are many techniques you will find in a search but many of them are flawed. This is my function that will find the last row

Public Function lastRow(rg As Variant) As Long
'Find the last row used in a worksheet - regardless of where the data starts and ends
'and regardless of whether the data is contiguous or jagged
'Note use of Variant for the input range parameter
'This allows both worksheets and ranges to passed into the function
    On Error Resume Next
    Dim lr As Long
    lr = rg.Cells.Find(What:="*" _
                    , LookAt:=xlPart _
                    , LookIn:=xlFormulas _
                    , SearchOrder:=xlByRows _
                    , SearchDirection:=xlPrevious).Row
    If Err.Number <> 0 Then
        lr = 1  'cater for a completely empty sheet
    End If
    On Error GoTo 0
    lastRow = lr
End Function

Here is an example of using it:

Dim lstRow As Long
lstRow = lastRow(ThisWorkbook.Sheets(1))

Once you have that you can set up the range for your table:

Dim rng As Range
Set rng = ThisWorkbook.Sheets(1).Range("$D$6:$G$" & CStr(lstRow))

If you record a macro selecting that area and inserting a table you get lots of lines of generated code. You need to strip it right back to the basics and utilise the rng variable e.g.

ThisWorkbook.Sheets(1).ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Demo"

However, it sounds more like you want to get an in-memory table of data - or a RecordSet. You can do that like this (includes a demo of extracting the data)

Sub Demo2()

    Dim lstRow As Long
    lstRow = lastRow(ThisWorkbook.Sheets(1))

    Dim rng As Range
    Set rng = ThisWorkbook.Sheets(1).Range("$D$6:$G$" & CStr(lstRow))

    'Late binding means not having to use a reference to Microsoft XML
    'But you don't get the benefit of Intellisense whilst writing code
    Dim oXML As Object
    Set oXML = CreateObject("MSXML2.DOMDocument")
    
    Dim rs As Object
    Set rs = CreateObject("ADODB.RecordSet")
        
    oXML.LoadXML rng.Value(xlRangeValueMSPersistXML)
    rs.Open oXML

    rs.MoveFirst
    Do While Not rs.EOF
        Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
        Debug.Print rs.Fields(" Col4"), rs.Fields(" Col5"), rs.Fields(" Col6"), rs.Fields(" Col7")
        rs.MoveNext
    Loop

End Sub

If it's neither of those things that you are after you're going to have to explain your problem in a much clearer way