how to create a new excel file to export data from access - with loop method

Not sure what your point is, but ...

- Why filtering column names instead of writing a new query without the "parasit" columns ?
- Why not using the copyFromRecordset method as it is faster (especially with heavy amount of data).
- why messing with rows and columns calculation when you have the range.offset() method available ?
- Selecting cells is useless (and slow).
- As transfering data, and formating are two different things, it should be in two separate functions (by respect for SRP).
- Better use late binding.
- Error handler where are you ?

Hi Fabrice Lambert,

am new to access vba. can you please help me how to make the above code more efficient. by using above mentioned suggestions.

More or less something like this:

Option Explicit

Private Sub cmdchemicalsearchexport_Click()
On Error GoTo Error
    Dim x1 As Object            '// Excel.Application
    Dim wb As Object            '// Excel.Workbook
    Dim ws As Object            '// Excel.worksheet
    Dim x1worksheetpath  As String
    Dim db As DAO.database
    Dim rs As DAO.Recordset
    Dim strSQL As String
    
    x1worksheetpath = "D:\test\"
    x1worksheetpath = x1worksheetpath & "ReportChemicalSearch.xlsx"
    
    strSQL = "..............." '// Your query here
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
    
    Set x1 = CreateObject("Excel.Application")
    Set wb = x1.Workbooks.Open(x1worksheetpath)
    Set ws = wb.Worksheets("sheet1")
    Set rng = ws.Range("A2")
    exportData rng
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set rng = Nothing
    formatData ws
    Set ws = Nothing
    x1.Visible = True
    Set x1 = Nothing
Exit Sub
Error:
    If Not (rs Is Nothing) Then
        rs.Close
        Set rs = Nothing
    End If
    If Not (db Is Nothing) Then
        Set db = Nothing
    End If
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        wb.Close savechanges:=False
        Set wb = Nothing
    End If
    If Not (x1 Is Nothing) Then
        x1.Quit
        Set x1 = Nothing
    End If
    MsgBox "The following execution error occured:" & vbCrLf & vbCrLf & Err.Description, vbOKOnly + vbCritical, "Error"
End Sub

Public Sub exportData(ByRef rs As DAO.Recordset, ByRef startAt As Object)
On Error GoTo Error
    If Not (rs.BOF And rs.EOF) Then
        rs.moveFirst
        startAt.CopyFromRecordset rs
    End If
Exit Sub
Error:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub formatData(ByRef ws As Object)
On Error GoTo Error
    Const xlContinuous = 1
    Dim rng As Object       '// Excel.Range
    
    Set rng = ws.UsedRange
    rng.Borders.LineStyle = xlContinuous
    ws.Cells.EntireColumn.AutoFit
    Set rng = Nothing
    ws.Cells("A1").value = "Trade Name"
    ws.Cells("A2").value = "Supplier"
    ws.Cells("A3").value = "Category"
    ws.Cells("A4").value = "Physical Appearance"
    ws.Cells("A5").value = "Active Ingredient"
    ws.Cells("A6").value = "Regional Availability"
    ws.Cells("A7").value = "EPA#"
    ws.Cells("A8").value = "Comment"
    ws.Range("A1:A8").Font.Bold = True
Exit Sub
Error:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Select allOpen in new window

The requirement isn't clear and I don't have time to study the code.  Is it necessary to do the export with automation at all or can it be done with a SINGLE statement - TransferSpreadaheet?

no . my requirement is show horizontal records to vertical records in excel sheet.

You can get faster performance and simpler code if you use the CopyFromRecordset method.

There is an explanation and link in my Fast Data Push article:
https://www.experts-exchange.com/articles/2253/Fast-Data-Push-to-Excel.html

Private Sub cmdchemicalsearchexport_Click()


 Dim saveloc As String, strWorksheetPath As String, xl As Object, wb As Object
    Dim exportsheet As Object, Header As Variant, OIHeader As Variant
    'Dim db As DAO.Database, ExportRecordSet As DAO.Recordset
   
Dim db As Database
Set db = CurrentDb
Dim rs As Recordset

    'Turning warnings off for procedure to execute
    'Commented out to get an error message if present
    'DoCmd.SetWarnings False

    'Setting Save location
    'saveloc = Environ("USERPROFILE") & "\Desktop\"
    saveloc = strWorksheetPath & "ChemicalSearchReport.xlsx"

    'Set db = CurrentDb

    'Instantiating Excel
    Set xl = CreateObject("Excel.Application")

    'Turning off Excel Warnings
    'Turning off warnings for testing
    'xl.DisplayAlerts = False


    'Adding new workbook to Excel Object
    Set wb = xl.Workbooks.Add

    'Naming worksheets
    Set exportsheet = wb.Worksheets(1)
    exportsheet.Name = "Chemical Search"

    'Setting Excel To Visible
    xl.Application.Visible = True

 
   Set rs = db.OpenRecordset(Me.RecordSource)
   
        exportsheet.Cells(1, 1).Value = "Trade Name"
        exportsheet.Cells(2, 1).Value = "Supplier"
        exportsheet.Cells(3, 1).Value = "Category"
        exportsheet.Cells(4, 1).Value = "Physical Appearance"
        exportsheet.Cells(5, 1).Value = "Active Ingredient"
        exportsheet.Cells(6, 1).Value = "Regional Availability"
        exportsheet.Cells(7, 1).Value = "EPA#"
        exportsheet.Cells(8, 1).Value = "Comment"
        exportsheet.Range("A1:A8").Font.Bold = True


    Dim rownum As Long, colnum As Long
    Dim i As Long
    i = 0
    rownum = 1
    colnum = 2
    rs.MoveFirst

    For Index = 1 To rs.Fields.Count
    If rs.Fields(i).Name <> "SDS" And rs.Fields(i).Name <> "CID" Then
        Do While Not rs.EOF
        exportsheet.Cells(rownum, colnum).Value = rs.Fields(i).Value
        rs.MoveNext
        colnum = colnum + 1



        Loop
        rownum = rownum + 1
        colnum = 2
    End If
    i = i + 1
    rs.MoveFirst
    Next
   
  With exportsheet
  .Cells(1, i).Select
   Set testRange = .Range(.Cells(1, 1), .Cells(i - 2, i + 1))
 End With
 
 
  testRange.Borders.LineStyle = xlContinuous

exportsheet.Cells.EntireColumn.AutoFit

    End Sub
got solution

Did you even look at our answers ?

Bc you posted pretty much the same code as your original post ..... with additional mistakes.

- Turning off access warning is useless since you arn't modifying any access object.
Plus you forgot to turn in back on, not a great experience for the user.
- Turning Excel warning off shold be done right before saving, in case of troubles you want Excel to remain in "warning-less" mode for as little time as possible.
Plus, you also forgot to turn it back on.

Rule of thumb:
Whenever you need to alter the user's environment, always give it back to its previous state.

I promise that if you leave warnings off in Access, you will be punished and it won't be a pretty sight when you slit your wrists because you've just lost eight hours of work due to careless coding.  Remembering to turn warnings back on is so important that I recommend that you create two macros.
1. mWarningsOff - turns warnings off and turns the hourglass on
2. mWarningsOn - turns warnings on and turns the hourglass off

Having the hourglass on when warnings are off gives you a visual clue that something is amiss and is sufficiently annoying that you won't let it go for long.  It is then easy enough to just run the macro to set the warnings back on while you search for the gap in your code.