1

Would anyone have suggestions to make this more efficient where I could define just the top left hand cell I want the table to start at and the rest would be dynamic / adjust accordingly based on that cell?

Would like to just define startHeader = ws.Range("A10") and remove the +9, -1 hardcodes

Set the worksheet and fix the start cell Step 1: Delete the existing table if it exists Clear previous data from downwards

Sub UpdateTableFromDatabaseIH()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim startHeader As Range
    Dim startCell As Range
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim lastRow As Long
    Dim newTableRange As Range
    Dim newTbl As ListObject
    Dim headerArray() As Variant
    Dim col As Long
    Dim row As Long
    Dim fieldValue As Variant
    Dim chunkSize As Long
    Dim totalValue As String
    
    Set ws = ThisWorkbook.Sheets("IH")
    Set startHeader = ws.Range("A10")
    Set startCell = ws.Range("A11")
       

    On Error Resume Next
    Set tbl = ws.ListObjects("Table_Query_from_report")
    On Error GoTo 0
    If Not tbl Is Nothing Then
        tbl.Delete
    End If
    

    ws.Range("A11", ws.Cells(ws.Rows.Count, ws.Columns.Count)).ClearContents
    
    ' Step 2: Connect to the database and retrieve the recordset
    Set conn = New ADODB.Connection
    conn.ConnectionString = "dSN=db;"
    conn.Open
    
    Set rs = New ADODB.Recordset
    rs.Open "call report.dr_h", conn
    
    ' Step 3: Write headers from recordset fields
    ReDim headerArray(0 To rs.Fields.Count - 1)
    For col = 0 To rs.Fields.Count - 1
        headerArray(col) = rs.Fields(col).Name
    Next col
    startHeader.Resize(1, rs.Fields.Count).Value = headerArray
    
    row = 2 + 9
    
    ' Step 4: Write the recordset data starting at D2 if not empty
    If Not rs.EOF Then
        Do While Not rs.EOF
            For col = 0 To rs.Fields.Count - 1
                If rs.Fields(col).Type = adLongVarChar Or rs.Fields(col).Type = adLongVarWChar Then
                    ' Handle large text fields with GetChunk
                    totalValue = ""
                    chunkSize = 1024 ' Read 1024 characters at a time
                    
                    On Error Resume Next
                    Do
                        fieldValue = rs.Fields(col).GetChunk(chunkSize)
                        If Err.Number <> 0 Then
                            Exit Do
                        End If
                        If IsNull(fieldValue) Or Len(fieldValue) = 0 Then
                            Exit Do
                        End If
                        totalValue = totalValue & fieldValue
                    Loop While Len(fieldValue) = chunkSize
                    On Error GoTo 0
                    
                    ' Excel cell limit is 32,767 characters
                    If Len(totalValue) > 32767 Then
                        ws.Cells(row, col + 1).Value = Left(totalValue, 32767) 
                    Else
                        ws.Cells(row, col + 1).Value = totalValue
                    End If
                Else
                    ' Handle other field types normally
                    fieldValue = rs.Fields(col).Value
                    If IsNull(fieldValue) Then
                        ws.Cells(row, col + 1).Value = ""
                    ElseIf VarType(fieldValue) = vbString And Len(fieldValue) > 32767 Then
                        ws.Cells(row, col + 1).Value = Left(fieldValue, 32767)
                    Else
                        ws.Cells(row, col + 1).Value = fieldValue
                    End If
                End If
            Next col
            
            row = row + 1
            rs.MoveNext
            
        Loop
        
        lastRow = row - 1
    Else
        lastRow = 1
    End If
    
    Application.StatusBar = False
    
    ' Step 5: Create the new table
    Set newTableRange = startHeader.Resize(lastRow - 9, rs.Fields.Count)
    Set newTbl = ws.ListObjects.Add(xlSrcRange, newTableRange, , xlYes)
    newTbl.Name = "Table_Query_from_report"

    ' Step 6: Clean up database connections
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    
    MsgBox "Data loaded successfully. " & (lastRow - 1) & " rows imported."
End Sub
1
  • 2
    Define a variable r as record counter and fill the tables with startCell.offset(r,col) instead ofws.Cells(row, col + 1).Value. Replace row = row + 1 with r= r+ 1. Then Set newTableRange = startHeader.Resize(r+1, rs.Fields.Count). Also Set startCell = startHeader.offset(1). Commented Jun 7 at 13:13

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.