How to create a macro in access

[ewarts]

How can I create a macro that will take the results from a query and export to a formatted excel sheet?

[BradHodge]

ewarts,

Use the TransferSpreads heet action. Your TransferType will be Export; choose your Spreadsheet Type; put in your query name (on the Table Name line); put in the path of where you want the spreadsheet saved (including the name of the file and .xls); say whether or not you want field names; you can probably leave the Range line blank.

Hope this helps,

Brad.

[BradHodge]

to a formatted excel sheet?

Just noticed the "formatted" part of your question. Experimented with macros and was not liking the results. Using VBA though, was able to get a query to export fine into an existing spreadsheet. It will append the new data into the spreadsheet.

If you need help on the code, let me know,

Brad.

[ewarts]

Did you have to setup a template first? there and already existing macro that export to excel by means of taking the queried result exporting it to one template then copying to the formatted sheet but it keeps aborting when moving from the first sheet to the second. I can send you the code.

[BradHodge]

Yeah... If you don't mind post your code.

Thanks.

Brad.

[ewarts]

Private Sub Workbook_Open()
Dim strsql As String
Dim strTW As String
Dim strHdr1 As String
Dim STRHDR2 As String
Dim xcnt As Integer
Dim ycnt As Integer
Dim rgend As String
Dim dd As Integer
Dim nn As String
strHdr1 = ""
STRHDR2 = ""
strTW = ThisWorkbook.Name
strsql = "SELECT * FROM Q" & Environ("username") & "_Staffing "


Workbooks.Add "\\dfs.ml.com\amrs\groups\GNSHeadcount$\SavedReports\Staffing.XLT"

dd = Workbooks.Count
nn = Workbooks(dd).Name

Workbooks(nn).Sheets(1).QueryTables.Add "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=;User ID=Admin;" & _
"Data Source=\\dfs.ml.com\amrs\groups\GNSHeadcount$\GNSHRDB.mdb", Workbooks(nn).Sheets(1).Range("A1"), strsql

[B]Workbooks(nn).Sheets(1).QueryTables(1).Refresh[/B]
Workbooks(nn).Sheets(1).QueryTables(1).Delete

strHdr1 = Cells(2, 1)
STRHDR2 = Cells(2, 2)

'workbooks(nn).sheets(1).PageSetup.CenterHeader = "&""" & "Verdana,Bold" & """ &14" & strHdr1 & Chr(10) & "&""Verdana,Italic""&11" & STRHDR2
xcnt = 65
Do While True
If xcnt > 90 Then
xcnt = 65
Do While True
If Workbooks(nn).Sheets(1).Range("A" & CStr(Chr(xcnt)) & CStr(1)) <> "" Then
xcnt = xcnt + 1
Else
xcnt = xcnt - 1
Exit Do
End If
Loop
rgend = "A" & CStr(Chr(xcnt))
Exit Do
Else
If Workbooks(nn).Sheets(1).Range(CStr(Chr(xcnt)) & CStr(1)) <> "" Then
xcnt = xcnt + 1
Else
xcnt = xcnt - 1
rgend = CStr(Chr(xcnt))
Exit Do
End If
End If
Loop


Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(1)).Interior.Color = 10053222
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(1)).Font.Color = 16777215

Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(1)).AutoFilter
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(1)).HorizontalAlignment = xlCenter

ycnt = 1
Do While True
If Workbooks(nn).Sheets(1).Range(rgend & CStr(ycnt)) <> "" Then
ycnt = ycnt + 1
Else
ycnt = ycnt - 1
Exit Do
End If
Loop
' If rgend & CStr(ycnt) <> "Q1" Then

Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlEdgeBottom).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlEdgeLeft).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlEdgeRight).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlEdgeTop).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlInsideHorizontal).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Borders(xlInsideVertical).LineStyle = 1
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).VerticalAlignment = xlBottom
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).VerticalAlignment = xlBottom
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).WrapText = True
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).Orientation = 0
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).AddIndent = False
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).ShrinkToFit = False
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).ReadingOrder = xlContext
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).MergeCells = False
Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt)).ColumnWidth = 12

Workbooks(nn).Sheets(1).Rows(1).Insert
Workbooks(nn).Sheets(1).Rows(1).Insert

Workbooks(nn).Sheets(1).Cells(1, 3) = Workbooks(nn).Sheets(1).Cells(4, 1)
Workbooks(nn).Sheets(1).Cells(2, 3) = Workbooks(nn).Sheets(1).Cells(4, 2)

Workbooks(nn).Sheets(1).Columns(1).Delete
Workbooks(nn).Sheets(1).Columns(1).Delete
rgend = Chr(Asc(rgend) - 2)
Workbooks(nn).Sheets(1).Range("A1", rgend & "1").Merge
Workbooks(nn).Sheets(1).Range("A2", rgend & "2").Merge

Workbooks(nn).Sheets(1).Range("A1").Font.Size = 14
Workbooks(nn).Sheets(1).Range("A1").Font.Bold = True
Workbooks(nn).Sheets(1).Range("A1").HorizontalAlignment = xlCenter

Workbooks(nn).Sheets(1).Range("A2").Font.Size = 11
Workbooks(nn).Sheets(1).Range("A2").Font.Italic = True
Workbooks(nn).Sheets(1).Range("A2").HorizontalAlignment = xlCenter

Workbooks(nn).Sheets(1).Range("M1", "M" & ycnt + 2).ColumnWidth = 35
Workbooks(nn).Sheets(1).Range("O1", "O" & ycnt + 2).ColumnWidth = 12.5

Workbooks(nn).Sheets(1).Range("A1", rgend & CStr(ycnt) + 2).Rows.AutoFit
Workbooks(nn).Sheets(1).Range("A1").RowHeight = 25
Workbooks(nn).Sheets(1).Range("A2").RowHeight = 12.5
Workbooks(nn).Sheets(1).PageSetup.PrintTitleRows = "$1:$3"
' Else
' workbooks(nn).sheets(1).Cells(2, 1) = "No Data For This Criteria"
' workbooks(nn).sheets(1).Range("A2", rgend & "2").Select
' Selection.MergeCells = True
'End If


Workbooks(dd - 1).Close SaveChanges:=False

End Sub

[ewarts]

The problem lies with the line below, the debugger goes to this line when I step through the code

Workbooks(nn).S heets(1).QueryT ables(1).Refres h

[BradHodge]

I'll look at and should be able to reply after I get home from work.

[BradHodge]

How can I create a macro that will take the results from a query and export to a formatted excel sheet?

My apologies. I thought you were trying to export from Access. But looking at your code, it appears you are trying to import an Access query from Excel. I'm not very familiar with Excel VBA syntax.

Brad.

[ewarts]

The code takes the the info from access to excel by way of vba

[FishVal]

Private Sub Workbook_Open()
...
End Sub

Hi, Ewarts.
In generally this should work. But the code isn't strong and may fail from many reasons. Try to replace your code from start to line "strHdr1 = Cells(2, 1)" exclusively with the following code.

Dim strsql As String
Dim strTW As String
Dim strHdr1 As String
Dim STRHDR2 As String
Dim xcnt As Integer
Dim ycnt As Integer
Dim rgend As String
Dim dd As Integer
Dim nn As String
Dim qtQueryTable As QueryTable
strHdr1 = ""
STRHDR2 = ""
strTW = ThisWorkbook.Name
strsql = "SELECT * FROM Q" & Environ("username") & "_Staffing "


Workbooks.Add "\\dfs.ml.com\amrs\groups\GNSHeadcount$\SavedReports\Staffing.XLT"

dd = Workbooks.Count
nn = Workbooks(dd).Name

Set qtQueryTable = Workbooks(nn).Sheets(1).QueryTables.Add _
("OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=;User ID=Admin;" & _
"Data Source=\\dfs.ml.com\amrs\groups\GNSHeadcount$\GNSHRDB.mdb", Workbooks(nn).Sheets(1).Range("A1"), strsql)

qtQueryTable.Refresh
qtQueryTable.Delete
Set qtQueryTable = Nothing

[NeoPa]

General point to all posters :
Please lay out code in standard format - especially when large amounts are included.
It is not fair to expect other readers to read what you post when it's not even indented.

MODERATOR.

[NeoPa]

I've included some quite general code to handle this situation (which I use quite heavily).
The constants at the top may well need to be customised for your environment, but the range where you want the results to go and the SQL of the query you want are passed as the parameters. Remember the Excel SQL restrictions are somewhat different to those you'll find in Access.

Private Const conDBDir As String = "H:\Database"
Private Const conDBName As String = "Reports.Mdb"
Private Const conJobName As String = "MyJob"

'GetDataFromAccess refreshes the data in the current sheet
'using strSQL in database conDBDir\conDBName.
Private Sub GetDataFromAccess(ranDest As Range, strSQL As String)
    Dim intRow As Integer, intMaxRow As Integer, intCol As Integer
    Dim strWork As String
    Dim namQuery As Name

    strWork = "ODBC;" & _
              "DSN=MS Access Database;" & _
              "DBQ=" & conDBDir & "\" & conDBName & ";" & _
              "DefaultDir=" & conDBDir & ";" & _
              "DriverId=25;" & _
              "FIL=MS Access;" & _
              "MaxBufferSize=2048;" & _
              "PageTimeout=5;"
    With ActiveSheet.QueryTables.Add(Connection:=strWork, Destination:=ranDest)
        .CommandText = strSQL
        .Name = conJobName
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        Call .Refresh(BackgroundQuery:=False)
        Call .Delete
    End With
    For Each namQuery In ActiveSheet.Names
        If InStr(1, namQuery.Name, conJobName) > 0 Then Call namQuery.Delete
    Next namQuery
End Sub

[ewarts]

Hi, Ewarts.
In generally this should work. But the code isn't strong and may fail from many reasons. Try to replace your code from start to line "strHdr1 = Cells(2, 1)" exclusively with the following code.

Dim strsql As String
Dim strTW As String
Dim strHdr1 As String
Dim STRHDR2 As String
Dim xcnt As Integer
Dim ycnt As Integer
Dim rgend As String
Dim dd As Integer
Dim nn As String
Dim qtQueryTable As QueryTable
strHdr1 = ""
STRHDR2 = ""
strTW = ThisWorkbook.Name
strsql = "SELECT * FROM Q" & Environ("username") & "_Staffing "


Workbooks.Add "\\dfs.ml.com\amrs\groups\GNSHeadcount$\SavedReports\Staffing.XLT"

dd = Workbooks.Count
nn = Workbooks(dd).Name

Set qtQueryTable = Workbooks(nn).Sheets(1).QueryTables.Add _
("OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=;User ID=Admin;" & _
"Data Source=\\dfs.ml.com\amrs\groups\GNSHeadcount$\GNSHRDB.mdb", Workbooks(nn).Sheets(1).Range("A1"), strsql)

qtQueryTable.Refresh
qtQueryTable.Delete
Set qtQueryTable = Nothing

FishVal,

Your code produced the same error as mine. From what I'm able to see is the refresh code is where the problem is. My code originally takes the queried result from the following worksheet (GNSHRStaff Report.xlt) to (Staffing1)

[FishVal]

FishVal,

Your code produced the same error as mine. From what I'm able to see is the refresh code is where the problem is. My code originally takes the queried result from the following worksheet (GNSHRStaff Report.xlt) to (Staffing1)

Try to do it manually via "Import data" menu command. If this works, then record a macro and copy/paste thus obtained code to your procedure.

Good luck.