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
ras record counter and fill the tables withstartCell.offset(r,col)instead ofws.Cells(row, col + 1).Value. Replacerow = row + 1withr= r+ 1. ThenSet newTableRange = startHeader.Resize(r+1, rs.Fields.Count). AlsoSet startCell = startHeader.offset(1).