bu modüle
Public Sub CopyRs2Sheet(strsql As String, strWorkBook As String, Optional strWorkSheet As String, Optional strCellRef As String)
'Uses the
Excel CopyFromRecordset method
'strSql:
Sql Select string
'strWorkBook: Full path and name to target wb, will create if doesn't exist
'strWorkSheet: Name of target worksheet, will create if doesn't exist
'strCellRef: Upper Left cell for data, defaults to A1
On Error GoTo ProcError
DoCmd.Hourglass True
'using late binding on
Excel
Dim objXLApp As Object '
Excel.Application
Dim objXLWb As Object '
Excel.Workbook
Dim objXLSheet As Object '
Excel.Worksheet
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim I As Integer
Dim iSheets As Integer
'set rs from sql, table or query
Set rs = CurrentDb.OpenRecordset(strsql, dbOpenSnapshot)
'start
Excel
Set objXLApp = CreateObject("
Excel.Application")
'open workbook, error routine will
'create it if doesn't exist
'only create workbooks with 1 sheet
iSheets = objXLApp.SheetsInNewWorkbook 'save user's setting
objXLApp.SheetsInNewWorkbook = 1 'set for only 1 sheet
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)
objXLApp.SheetsInNewWorkbook = iSheets 'restore user's setting
'select a worksheet, if sheet doesn't exist
'the error routine will add it
If strWorkSheet = "" Then
strWorkSheet = "Sheet1"
End If
'If Range is missing default to A1
If strCellRef = "" Then
strCellRef = "A1"
End If
'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)
'insert recordset into
Excel Worksheet using CopyFromRecordset method
objXLSheet.Range(strCellRef).CopyFromRecordset rs
objXLSheet.Columns.AutoFit
'Save wb
objXLWb.Save
objXLWb.Close
'close up other rs objects
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
Set objXLSheet = Nothing
Set objXLWb = Nothing
'quit
Excel
If Not objXLApp Is Nothing Then objXLApp.Quit
Set objXLApp = Nothing
DoCmd.Hourglass False
Exit Sub
ProcError:
Select Case Err
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet
Resume Next
Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook
Resume Next
Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Stop
Resume 0
End Select
End Sub
buda formun istediğin bir yerine yada düğmeye
Dim stFile As String
Dim strSQL2 As String
strSQL2 = "SELECT * From sor1 "
strSQL2 = strSQL2 & "WHERE DURUM Like '" & durumum & "' And YILAYGÜN=" & ayımyılım
stFile = CurrentProject.Path & "\" & durumum & ".xls"
Call CopyRs2Sheet(strSQL2, stFile, "Sayfa1", "A1")
nott=tabi her zamanki gibi bu kodda kod deposunda var biraz uğraş ile hepsi bulunur
meşhur çin atasözü "ACCESS İLE YAPABİLECEKLERİNİZ HAYAL EDEBİLECEKLERİNİZ İLE SINIRLIDIR" siz ne kadar hayal edebiliyorsunuz