Larry,
I know it's hard to explain what I was after. I since got some help from a
guy I used to work with. He did some VB programming that was exactly what I
was after. I'll try to attach a scaled down version here if it will allow me.
I don't understand all the code, but basically it. takes the Table and
qroups it by office and sums up "Absolute" and exports it to Excel as a
Summary sheet. Then it takes each Office and provides 80% of the Summary
amount with detail records in descending order on a Tab on the same
spreadsheet.
Here's what he had in a module. You'll need to add Microsoft Excel Library
11.0
you need a table with two fields, Office and Absolute and query called
"Summary by Office" I'll send a DB to you if you like. I understand what
it's doing, but not how.
Option Compare Database
Option Explicit
Global dbs As Database, rs As Recordset, tdf As TableDef, qry As QueryDef,
fld As Field, idx As Index, i As Integer, SQLStr As String
Global strFilter As String, strInputFileName As String, strInputPath As
String, LastSlash As Integer
Global qdf As QueryDef, TitleStr As String
Global Clmn As Integer, XPrtDir As String, XPrtQry As String, AutoFltrOn As
Boolean, CalcTotals As Boolean, MaxDate As Date
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA"
(ofn As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA"
(ofn As OPENFILENAME) As Boolean
Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal
lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Global Const OFN_ALLOWMULTISELECT = &H200
Global Const OFN_CREATEPROMPT = &H2000
Global Const OFN_EXPLORER = &H80000
Global Const OFN_FILEMUSTEXIST = &H1000
Global Const OFN_HIDEREADONLY = &H4
Global Const OFN_NOCHANGEDIR = &H8
Global Const OFN_NODEREFERENCELINKS = &H100000
Global Const OFN_NONETWORKBUTTON = &H20000
Global Const OFN_NOREADONLYRETURN = &H8000
Global Const OFN_NOVALIDATE = &H100
Global Const OFN_OVERWRITEPROMPT = &H2
Global Const OFN_PATHMUSTEXIST = &H800
Global Const OFN_READONLY = &H1
Global Const OFN_SHOWHELP = &H10
Function CommonFileOpenSave( _
Optional ByRef Flags As Variant, _
Optional ByVal InitialDir As Variant, _
Optional ByVal Filter As Variant, _
Optional ByVal FilterIndex As Variant, _
Optional ByVal DefaultExt As Variant, _
Optional ByVal FileName As Variant, _
Optional ByVal DialogTitle As Variant, _
Optional ByVal hWnd As Variant, _
Optional ByVal OpenFile As Variant) As Variant
' This is the entry point you'll use to call the common file open/save dialog.
' The parameters are listed below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim ofn As OPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
' Give the dialog a caption title.
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(Filter) Then Filter = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(Flags) Then Flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(hWnd) Then hWnd = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
' Allocate string space for the returned strings.
strFileName = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hWnd
.strFilter = Filter
.nFilterIndex = FilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = DialogTitle
.Flags = Flags
.strDefExt = DefaultExt
.strInitialDir = InitialDir
' Didn't think most people would want to deal with these options.
.hInstance = 0
'.strCustomFilter = ""
'.nMaxCustFilter = 0
.lpfnHook = 0
'New for NT 4.0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
End With
' This will pass the desired data structure to the
' Windows API, which will in turn it uses to display the Open/Save As Dialog.
If OpenFile Then
fResult = GetOpenFileName(ofn)
Else
fResult = GetSaveFileName(ofn)
End If
' The function call filled in the strFileTitle member
' of the structure. You'll have to write special code
' to retrieve that if you're interested.
If fResult Then
' You might care to check the Flags member of the
' structure to get information about the chosen file.
' In this example, if you bothered to pass in a
' value for Flags, we'll fill it in with the outgoing Flags value.
If Not IsMissing(Flags) Then Flags = ofn.Flags
CommonFileOpenSave = TrimNull(ofn.strFile)
Else
CommonFileOpenSave = vbNullString
End If
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then TrimNull = Left(strItem, intPos - 1) Else TrimNull =
strItem
End Function
Public Function OpenFile(sFileName As String)
OpenFile = ShellExecute(Application.hWndAccessApp, "Open", sFileName, "",
"e:\common files", 1)
End Function
Function Cre8Dir(strInputFileName, XPrtDir)
'Find the last slash (Asc 92) and identify the path.
For i = 1 To Len(strInputFileName)
If Asc(Mid(strInputFileName, i, 1)) = 92 Then LastSlash = i + 1
Next i
strInputPath = Left(strInputFileName, LastSlash - 1)
'Create a new directory for the spreadsheets.
strInputPath = strInputPath & XPrtDir & Format(Date, "mmddyy")
If Dir$(strInputPath, vbDirectory) = "" Then
MkDir strInputPath
End If
strInputPath = strInputPath & "\"
End Function
Function XportResearchDetail()
Dim XportName As String
On Error GoTo ExitThis
XportName = "Research_Detail_" & Format(Date, "mmddyy")
strInputFileName = CommonFileOpenSave(Filter:="Excel Files (*.xls)" &
vbNullChar & "*.xls" & vbNullChar, _
OpenFile:=False, FileName:=XportName & ".xls", _
DialogTitle:=" Identify the directory to create the spreadsheets in.",
Flags:=OFN_HIDEREADONLY, _
InitialDir:=Application.CurrentProject.Path)
If strInputFileName = "" Then GoTo ExitThis
'*** This section of code determines if a spreadsheet already exists and
if so, deletes it."
If Dir$(strInputFileName) <> "" Then
SetAttr strInputFileName, vbNormal
Kill strInputFileName
End If
On Error GoTo 0
On Error GoTo ErrHandler
Dim TblName As String, DetailFields As String, MainQry As String, QryName As
String, rs2 As Recordset, DetailAmt As Currency, TempFld As String
TblName = "UMD_Data_Analysis"
DetailFields = "Office, Absolute"
MainQry = "Summary By Office"
SQLStr = "SELECT Office, Sum(Absolute) AS [Total Amount],
Sum([Absolute])*0.8 AS [Research%] FROM [" & TblName & "] GROUP BY Office;"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, MainQry,
strInputFileName, -1
Set dbs = CurrentDb
Set tdf = dbs.TableDefs(TblName)
IDTempField:
TempFld = i + 1
For i = 1 To tdf.Fields.Count - 1 Step 1
If tdf.Fields(i).Name = TempFld Then
GoTo IDTempField
End If
Next i
tdf.Fields.Append tdf.CreateField(TempFld, dbBoolean)
dbs.TableDefs.Refresh
Set rs = dbs.OpenRecordset(MainQry, dbOpenSnapshot)
rs.MoveFirst
Do
DetailAmt = 0
Set rs2 = dbs.OpenRecordset("SELECT Office, Absolute, [" & TempFld & "]
FROM [" & TblName & "] " _
& "WHERE Office = '" & rs!Office & "' ORDER BY Absolute DESC;",
dbOpenDynaset)
rs2.MoveFirst
Do
DetailAmt = DetailAmt + rs2!absolute
rs2.Edit
rs2(TempFld) = True
rs2.Update
rs2.MoveNext
Loop Until DetailAmt >= rs![Research%] Or rs2.EOF
rs.MoveNext
Loop Until rs.EOF
rs2.Close
rs.MoveFirst
Do
QryName = ""
For i = 1 To Len(rs!Office)
Select Case Asc(UCase(Mid(rs!Office, i, 1)))
Case 65 To 90: QryName = QryName & UCase(Mid(rs!Office, i, 1)) '65 To
90 = "A" To "Z"
Case 48 To 57: QryName = QryName & UCase(Mid(rs!Office, i, 1)) '48 To
57 = "0" To "9"
End Select
Next i
SQLStr = "SELECT " & DetailFields & " FROM [" & TblName & "] " _
& "WHERE ((Office = '" & rs!Office & "') And ([" & TempFld & "] = True))
ORDER BY Absolute DESC;"
'*** This section of code deletes specified tables
For i = dbs.TableDefs.Count - 1 To 0 Step -1
If dbs.TableDefs(i).Name = QryName Then dbs.TableDefs.Delete QryName
Next i
'*** This section of code deletes specified queries
For i = dbs.QueryDefs.Count - 1 To 0 Step -1
If dbs.QueryDefs(i).Name = QryName Then dbs.QueryDefs.Delete QryName
Next i
'*** Create the query, export it and delete it.
Set qdf = dbs.CreateQueryDef(QryName, SQLStr)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, QryName,
strInputFileName, -1
dbs.QueryDefs.Delete QryName
'*** Identify the next query to export
rs.MoveNext
Loop Until rs.EOF
rs.Close
tdf.Fields.Delete (TempFld)
'*** Open the Excel spreadsheet.
Workbooks.Open FileName:=strInputFileName
Dim CS As Integer, LS As Integer, LC As Integer, LR As Integer
CS = 1
LS = Sheets.Count
For CS = 1 To LS Step 1
Worksheets(CS).Select
With Selection
LC = ActiveCell.SpecialCells(xlLastCell).Column
'*** Set the font attributes.
Cells.Font.Name = "Arial"
Cells.Font.FontStyle = "Regular"
Cells.Font.Size = 10
Cells.VerticalAlignment = xlTop
Cells.WrapText = False
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
'*** Set the color of the top row on the worksheet.
Range(Cells(1, 1), Cells(1, LC)).Interior.ColorIndex = 15
Cells(1, 1).EntireRow.AutoFilter
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
End With
Next CS
Worksheets(1).Select
'*** Save, close and reopen the spreadsheet
Workbooks(1).Close savechanges:=True
OpenFile (strInputFileName)
ExitThis: DoCmd.Hourglass False
DoCmd.SetWarnings True
Exit Function
ErrHandler: MsgBox Error$
Resume ExitThis
End Function
