Home » excel » vba – How to set-up headers to a newly exported excel file by updating the below macro, which generates new excel file every time it was run?

vba – How to set-up headers to a newly exported excel file by updating the below macro, which generates new excel file every time it was run?

Posted by: admin May 14, 2020 Leave a comment

Questions:

The below query generates a new excel file with data from sql server every time it was run. But the generated excel file don’t have column headers in it, making it difficult to understand which column is what. So I am interested inserting 5 bold column header names like column_header1, column_header2….column_header5 in the first row of the excel and let the data start from the second row

Sub TEXT()

    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon, strSQL As String
    Dim MRC As Variant

    strCon = "some_string_connection"    
    MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
    strSQL = MRC    'Sql Query

    Sheets("Summary").Select
    With ActiveWorkbook.Connections("Connection1").OLEDBConnection
        .CommandText = HR
        .CommandType = xlCmdSql
    End With
    ActiveWorkbook.Connections("Connection1").Refresh    

    Folder = "U:\"  'Path in U drive
    Filename = "Filename" & ".xls"
    fpath = Folder & Filename

    cn.Open strCon
    cn.CommandTimeout = 0
    rs.ActiveConnection = cn
    rs.Open strSQL

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set A = fs.CreateTextFile(fpath)
    A.Write (rs.GetString(adClipString, , , vbCrLf, ""))

    rs.Close
    cn.Close
    Set cn = Nothing
End Sub
How to&Answers:

You are writing to the Excel file here:

A.Write (rs.GetString(adClipString, , , vbCrLf, ""))

Thus, this is the place, where you should put your headers. Something like this should be ok:

A.Write "column_header1, column_header2, column_header5" & vbCrLf & _
        rs.GetString(adClipString, , , vbCrLf, "")

Answer:

There are two method.

First method.

Use rs.field and variant array.

Dim vR() As Variant
Dim str As String

For i = 0 To Rs.Fields.Count - 1
   ReDim Preserve vR(i)
   vR(i) = Rs.Fields(i).Name
Next

Second method is add new workbook and write fields and record.

If Not Rs.EOF Then
     With Ws
        .Range("a4").CurrentRegion.Clear
        For i = 0 To Rs.Fields.Count - 1
           .Cells(1, i + 1).Value = Rs.Fields(i).Name
        Next
        .Range("a2").CopyFromRecordset Rs
        .Columns.AutoFit
    End With
Else
    MsgBox "There is no record!", vbCritical
End If

First full code.

Sub TEXT()

    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon, strSQL As String
    Dim MRC As Variant

    strCon = "some_string_connection"
    MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
    strSQL = MRC    'Sql Query

    Sheets("Summary").Select
    With ActiveWorkbook.Connections("Connection1").OLEDBConnection
        .CommandText = HR
        .CommandType = xlCmdSql
    End With
    ActiveWorkbook.Connections("Connection1").Refresh

    Folder = "U:\"  'Path in U drive
    Filename = "Filename" & ".xls"
    fpath = Folder & Filename

    cn.Open strCon
    cn.CommandTimeout = 0
    rs.ActiveConnection = cn
    rs.Open strSQL

    Dim vR() As Variant
    Dim str As String, i As Integer

    For i = 0 To rs.Fields.Count - 1
       ReDim Preserve vR(i)
       vR(i) = rs.Fields(i).Name
    Next

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set A = fs.CreateTextFile(fpath)

    str = Join(vR, vbTab) & vbCrLf
    A.Write str
    A.Write (rs.GetString(adClipString, , , vbCrLf, ""))

    rs.Close
    cn.Close
    Set cn = Nothing
End Sub

Second full code.

Sub TEXT2()

    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon, strSQL As String
    Dim MRC As Variant

    strCon = "some_string_connection"
    MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
    strSQL = MRC    'Sql Query

    Sheets("Summary").Select
    With ActiveWorkbook.Connections("Connection1").OLEDBConnection
        .CommandText = HR
        .CommandType = xlCmdSql
    End With
    ActiveWorkbook.Connections("Connection1").Refresh

    Folder = "U:\"  'Path in U drive
    Filename = "Filename" & ".xls"
    fpath = Folder & Filename

    cn.Open strCon
    cn.CommandTimeout = 0
    rs.ActiveConnection = cn
    rs.Open strSQL

    Dim WB As Workbook, Ws As Worksheet
    Dim i As Integer

    Set WB = Workbooks.Add(Template:=xlWorksheet)
    Set Ws = ActiveSheet
    If Not rs.EOF Then
         With Ws
            For i = 0 To rs.Fields.Count - 1
               .Cells(1, i + 1).Value = rs.Fields(i).Name
            Next
            .Range("a2").CopyFromRecordset rs
            .Columns.AutoFit
        End With
    Else
        MsgBox "There is no record!", vbCritical
    End If
    WB.SaveAs fpath
    WB.Close (0)
    rs.Close
    cn.Close
    Set cn = Nothing
End Sub