AccessTr.neT

Selamlar
Aktif olan bir Özet Tablo/Form u Excel e göndermek için

Kod:
DoCmd.RunCommand acCmdPivotTableExportToExcel

kullanıyorum, bir hata mesajına rağmen sonuç başarılı.
Ancak, kapalı olan bir Özet tablo sorgusunu
İsmini, adresini belirterek Excel' e pivot olarak vermek
istiyorum. Aşağıdaki kodu net te gördüm :

Kod:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Table1", "D:\Book1.xls", False, "Sheet1$"

Sanırım "DoCmd.RunCommand acCmdPivotTableExportToExcel" parametre
kabul etmediği için bu kod tercih edilmiş, ancak ben çalıştıramadım
Sonuç olarak :
Kapalı bir ÖzetTablo sorgusunu Excel' e pivot olarak nasıl gönderirim
Teşekkürler
[Resim: screenhunter01apr211445.jpg]

[Kapalı bir ÖzetTablo sorgusunu ] dan kastinizi anlaymadim.
Sunumu demek istediniz; her hangi bir sorgunun bahse konu kodlar ile calistirilarak Pivot Table a aktarilmasindan mi bahsediyorsunuz?
Yoksa baska bi sey mi?

Herhangi bir sorguyu görünümden "Özet tablo görünümü"
olarak seçip design ettiğinizde, bu bilgiler saklanabiliyor ve ayni
sorguyu "özet tablo görünümünde" açarak
DoCmd.RunCommand acCmdPivotTableExportToExcel
komutuyla Excel e gönderdiğinizde sorgunun design bilgileriyle
(Bırakma alanları, satır, sütun, body, vs ) Excel e gidiyor. Yani Excel de
tekrardan pivot tablo düzenlemeleri yapmanıza gerek kalmıyor.
Benim problemim ( sorgu hidden-gizli ) olarak açılamadığı için
ya da ben öyle biliyorum, kapalı bir sorgunun ismini belirterek
export etmek

Oysa yukarıdaki kod sadece aktif olan sorguyu problemsiz atabiliyor

Not: İlk notuma bir resim ekledim. Bu örnek te görülen özet tablo
bir form ve aktif . Dolayısı ile yine yukarıdaki kod ile ayni design ı
excel e sorunsuz atıyor

bir sorgu yapın ona parametre belirtin ve onu export edebilrsin yada buna benzer bir kod uygularsın

Kod:
Function fProcErrs()

    On Error GoTo Proc_Err

    Dim booLeaveOpen As Boolean

    Dim wbkNew As Workbook

    Dim wksData As Worksheet

    Dim dbLocal As Database

    Dim snpErrors As DAO.Recordset

    Dim intCurrTask As Integer

    Dim rngCurr As Excel.Range

    Dim wksPivot As Worksheet

    Dim Cache As Excel.PivotCache

    Dim pTable As Excel.PivotTable

    Dim strSQL As String

    'if Excel is already open, use that instance

    booLeaveOpen = True

    'attempting to use something that is not available will

    'generate an error

    On Error Resume Next

    Set xlApp = GetObject(, "Excel.Application")

    On Error GoTo Proc_Err

    'if xlApp is defined then we already have a conversation

    If TypeName(xlApp) = "Nothing" Then

        booLeaveOpen = False

        'Excel was not open - create new instance

        Set xlApp = CreateObject("Excel.Application")

    End If

    xlApp.Visible = True

    Set wbkNew = xlApp.Workbooks.Add

    Set wksData = wbkNew.ActiveSheet

    Set wksPivot = wbkNew.Sheets(2)

    wksPivot.Name = "Pivot"

    wksData.Name = "ProcErrors"

     Set dbLocal = CurrentDb()

    strSQL = "SELECT tbl_AuditTypes.AuditType, tbl_AuditData.AudDate, " & _

        "tbl_AuditData.ClaimNumber, tbl_PQuestData.QNotes, tbl_PQuestData.Qnum, " & _

        "tbl_Questions.Question, [BSFirstName] & ' ' & [BSLastName] AS Assignee, " & _

        "[AudFirstName] & ' ' & [AudLastName] AS Auditor, [MgrFirstName] & ' ' & [MgrLastName] AS Manager, " & _

        "tbl_Office.Office, [SupFirstName] & ' ' & [SupLastName] AS Supervisor, tbl_Training.Training " & _

        "FROM tbl_Auditors INNER JOIN (tbl_Office INNER JOIN (((tbl_ManagerID " & _

        "INNER JOIN tbl_Supervisor ON tbl_ManagerID.MgrID = tbl_Supervisor.MgrID) " & _

        "INNER JOIN tbl_Assignee ON tbl_Supervisor.SupID = tbl_Assignee.SupID) " & _

        "INNER JOIN ((tbl_AuditTypes INNER JOIN (tbl_AuditData INNER JOIN tbl_Training " & _

        "ON tbl_AuditData.TrnID = tbl_Training.TrnID) ON tbl_AuditTypes.AudTyID = " & _

        "tbl_AuditData.AudTyID) INNER JOIN (tbl_Questions INNER JOIN tbl_PQuestData " & _

        "ON tbl_Questions.QID = tbl_PQuestData.QID) ON tbl_AuditData.AuditID = " & _

        "tbl_PQuestData.AuditID) ON tbl_Assignee.AssignID = tbl_AuditData.AssignID) " & _

        "ON tbl_Office.OfficeID = tbl_Assignee.OfficeID) ON tbl_Auditors.AuditorID = " & _

        "tbl_AuditData.AuditorID " & _

        "WHERE (((tbl_AuditData.AudDate) Between #" & [Forms]![frm_ErrorRpts]![StartDate] & "# And" & _

        " #" & [Forms]![frm_ErrorRpts]![EndDate] & "#) " & _

        " AND((tbl_PQuestData.Response)=0));"

    'Debug.Print strSQL

    Set snpErrors = dbLocal.OpenRecordset(strSQL, dbOpenSnapshot)

    snpErrors.MoveLast

    snpErrors.MoveFirst

    Set rngCurr = wksData.Range(wksData.Cells(2, 1), _

        wksData.Cells(2 + snpErrors.RecordCount, 1))

    'populates new worksheet with data from qry_Errors

    rngCurr.CopyFromRecordset snpErrors

Resume430:

    'adds column headings and some formatting

    With wksData

      .Cells(1, 1).Value = "Audit Type"

      .Cells(1, 1).Font.Bold = True

      .Cells(1, 2).Value = "Audit Date"

      .Cells(1, 2).Font.Bold = True

      .Cells(1, 3).Value = "Claim Number"

      .Cells(1, 3).Font.Bold = True

      .Cells(1, 4).Value = "Comments"

      .Cells(1, 4).Font.Bold = True

      .Cells(1, 5).Value = "Question Number"

      .Cells(1, 5).Font.Bold = True

      .Cells(1, 6).Value = "Question"

      .Cells(1, 6).Font.Bold = True

      .Cells(1, 7).Value = "Assignee"

      .Cells(1, 7).Font.Bold = True

      .Cells(1, 8).Value = "Auditor"

      .Cells(1, 8).Font.Bold = True

      .Cells(1, 9).Value = "Manager"

      .Cells(1, 9).Font.Bold = True

      .Cells(1, 10).Value = "Office"

      .Cells(1, 10).Font.Bold = True

      .Cells(1, 11).Value = "Supervisor"

      .Cells(1, 11).Font.Bold = True

      .Cells(1, 12).Value = "Training"

      .Cells(1, 12).Font.Bold = True

      .Columns("A:L").AutoFit

      .Columns("A:L").WrapText = True

      .Columns("D").ColumnWidth = 50

      .Columns("F").ColumnWidth = 50

   End With

    Set Cache = xlApp.ActiveWorkbook.PivotCaches.Add( _

    xlDatabase, wksData.Name & "!R1C1:R" & snpErrors.RecordCount + 1 & "C12")

    Set pTable = Cache.CreatePivotTable(wksPivot.Cells(4, 1), "PivotTable1")

    wksPivot.Select

    Set wksPivot = wbkNew.ActiveSheet

    xlApp.ActiveSheet.PivotTables("PivotTable1").SmallGrid = False

    'format pivot table

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Audit Type")

        .Orientation = xlPageField

        .Position = 1

    End With

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Question")

        .Orientation = xlRowField

        .Position = 1

    End With

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Claim Number")

        .Orientation = xlDataField

        .Position = 1

    End With

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Claim Number")

        .Orientation = xlDataField

        .Position = 2

    End With

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Data")

        .Orientation = xlColumnField

        .Position = 1

    End With

    With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields( _

        "Count of Claim Number2")

        .Calculation = xlPercentOfColumn

        .NumberFormat = "0%"

    End With

    With wksPivot

        .Columns("A").ColumnWidth = 50

    End With

        xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Audit Type").CurrentPage = _

        "Dental BS Audit"

Proc_Exit:

    On Error Resume Next

    If TypeName(xlApp) <> "Nothing" Then

        'xlApp.ActiveWorkbook.Close True

        'If Not booLeaveOpen Then xlApp.Quit

        Set xlApp = Nothing

    End If

    Exit Function

Konu, gereksiz mesajlar silinerek cevaplanmış sorular bölümüne taşınmıştır, kod için teşekkürler Eşref hocam.

okileturc

Nika

okileturc

esrefigit

ozanakkaya