Skip to main content

AccessTr.neT


Pivot sorguyu Excel e pivot tablo olarak göndermek

Pivot sorguyu Excel e pivot tablo olarak göndermek

Çözüldü #1
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]
okileturc, 18-03-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
Çözüldü #2
[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?
Cevapla
Çözüldü #3
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
okileturc, 18-03-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
Çözüldü #4
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

meşhur çin atasözü  "ACCESS İLE YAPABİLECEKLERİNİZ HAYAL EDEBİLECEKLERİNİZ İLE SINIRLIDIR" siz ne kadar hayal edebiliyorsunuz
Cevapla
Çözüldü #5
Konu, gereksiz mesajlar silinerek cevaplanmış sorular bölümüne taşınmıştır, kod için teşekkürler Eşref hocam.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da