With thanks to PHV, the below code allows selecting an Excel spreadsheet to export to, but my intent is to only
export the current record and subform record. Instead, all
records are cycled through, one replacing the previous.
Also, the sheet1 tab increments with each record; and
records don't properly display all fields. Any suggestions?
Thanks
John
a bit lengthy, sorry
---- Code (Access 97 and eventually, Access 2000)
Private Sub cmdExcel_Click()
' credit "vbslammer" - Open Excel worksheet from Access
On Error Resume Next
Dim dbmain As DAO.Database
Dim rec_members As DAO.Recordset
Dim rec_report As DAO.Recordset
Dim str_mem_SQL As String
Dim str_rep_SQL As String
Dim int_member As Double
Dim intR, IntC As Integer
Set dbmain = CurrentDb()
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim sht As Excel.Worksheet
Set xl = GetObject(, "Excel.Application")
If err.Number <> 0 Then
Set xl = CreateObject("Excel.Application")
'Else: Set xl = New Excel.Application 'instantiate Excel
End If
xl.Visible = True
' use Excel's built-in open dialog
xl.Dialogs(xlDialogOpen).Show "C:\*.xls"
Set wb = xl.ActiveWorkbook
str_mem_SQL = "SELECT DISTINCT CustomerID FROM qdfAll"
Set rec_members = dbmain.OpenRecordset(str_mem_SQL)
' rec_members.MoveFirst
Do Until rec_members.EOF = True
intR = 8
IntC = 2
int_member = rec_members![CustomerID]
str_rep_SQL = "SELECT * FROM qdfAll WHERE CustomerID = " & int_member
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
' put appropriate sheet name/index here.
Set sht = wb.Sheets(1)
With sht
.Name = int_member
.Range("B2").Value = rec_report![Subgect]
.Range("B3").Value = rec_report![CustomerID]
.Range("b4").Value = rec_report![Concerning]
.Range("B5").Value = rec_report![SubjectInfo]
.Range("B7").Value = rec_report![Todo]
.Range("C7").Value = rec_report![Status]
.Range("D7").Value = rec_report![Category]
.Range("E7").Value = rec_report![DocLink]
.Range("F7").Value = rec_report![Account]
.Range("G7").Value = rec_report![Essence]
.Range("H7").Value = rec_report![AreaCode]
.Range("I7").Value = rec_report![WebSite]
.Range("J7").Value = rec_report![Address]
.Range("K7").Value = rec_report![City]
.Range("L7").Value = rec_report![State]
' End With
Do Until rec_report.EOF = True
' With sht
.Cells(intR, IntC + 1).Value = rec_report![Subgect]
.Cells(intR, IntC + 2).Value = rec_report![CustomerID]
.Cells(intR, IntC + 3).Value = rec_report![Concerning]
.Cells(intR, IntC + 4).Value = rec_report![SubjectInfo]
.Cells(intR, IntC + 5).Value = rec_report![Todo]
.Cells(intR, IntC + 6).Value = rec_report![Status]
.Cells(intR, IntC + 7).Value = rec_report![Category]
.Cells(intR, IntC + 8).Value = rec_report![DocLink]
.Cells(intR, IntC + 9).Value = rec_report![Account]
.Cells(intR, IntC + 10).Value = rec_report![Essence]
.Cells(intR, IntC + 11).Value = rec_report![AreaCode]
.Cells(intR, IntC + 12).Value = rec_report![WebSite]
.Cells(intR, IntC + 13).Value = rec_report![Address]
.Cells(intR, IntC + 14).Value = rec_report![City]
.Cells(intR, IntC + 15).Value = rec_report![State]
' End With
intR = intR + 1
rec_report.MoveNext
Loop
rec_report.close
Set rec_report = Nothing
' range properties
' With .Range("E20", "G20")
' .Merge
' .Value = "Merged Cells"
' .HorizontalAlignment = xlHAlignCenter
' .Font = "Comic Sans"
' .Font.Size = 18
' .Font.Bold = True
' .Interior.ColorIndex = 27
' End With
' .Activate
'End With
.Columns("K:L").EntireColumn.Hidden = True
.Range("B7:J7").Font.Bold = True
.Range("B7:J7").Interior.ColorIndex = 15
With .Range("B2:B5")
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
.Font.Size = 11
.Font.Bold = True
End With
With .PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
.Columns("B:B").ColumnWidth = 9.43
.Columns("C:C").ColumnWidth = 44.14
.Columns("D
").ColumnWidth = 10.29.Columns("E:E").ColumnWidth = 16.29
.Columns("F:F").ColumnWidth = 16.57
.Columns("G:G").ColumnWidth = 10.57
.Columns("H:H").ColumnWidth = 16.44
.Columns("I:I").ColumnWidth = 11.29
.Columns("J:J").ColumnWidth = 13.29
End With
rec_members.MoveNext
Loop
rec_members.close
Set rec_members = Nothing
xl.DisplayAlerts = False
wb(1).Worksheets("SHEET1").Delete
wb(1).Worksheets("SHEET2").Delete
wb(1).Worksheets("SHEET3").Delete
End Sub
