Kod:
Option Compare Database
Public Sub CopyRs2Sheet(strsql As String, strWorkBook As String, Optional strWorkSheet As String, Optional strCellRef As String)
On Error GoTo ProcError
DoCmd.Hourglass True
Dim objXLApp As Object
Dim objXLWb As Object
Dim objXLSheet As Object
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim I As Integer
Dim iSheets As Integer
Set rs = CurrentDb.OpenRecordset(strsql, dbOpenSnapshot)
Set objXLApp = CreateObject("Excel.Application")
iSheets = objXLApp.SheetsInNewWorkbook
objXLApp.SheetsInNewWorkbook = 1
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)
objXLApp.SheetsInNewWorkbook = iSheets
If strWorkSheet = "" Then
strWorkSheet = "Sheet1"
End If
If strCellRef = "" Then
strCellRef = "A1"
End If
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)
objXLSheet.Range(strCellRef).CopyFromRecordset rs
objXLSheet.Columns.AutoFit
objXLWb.Save
objXLWb.Close
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
Set objXLSheet = Nothing
Set objXLWb = Nothing
If Not objXLApp Is Nothing Then objXLApp.Quit
Set objXLApp = Nothing
DoCmd.Hourglass False
Exit Sub
ProcError:
Select Case Err
Case 9
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet
Resume Next
Case 1004
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 Subbuda düğme kodu yalnız unutma eskisini siler yenisini ekler
Kod:
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"
Kill stFile
Call CopyRs2Sheet(strSQL2, stFile, "Sayfa1", "A1")