Skip to main content

AccessTr.neT


2007 Raporu Excele Aktarma

2007 Raporu Excele Aktarma

#7
Sayın ozanakkaya hocam referans ekledim o kısımı hallettikten sonra ikinci hatayı verdi.
Cevapla
#8
Merhaba, toplam kısmındaki sorun için, kod içerisindeki

Range("F4:G" & rs.RecordCount + 4 & "").NumberFormat = "#,##0.00 $"

kodunu iptal ederek deneyiniz.
Cevapla
#9
ozanakkaya hocam özür dilerim ben size yanlış izah ettim. Alt taraftaki toplamı getirmiyor diyecektim. Yani her kurumun kendi genel toplamı.
Cevapla
#10
Dim xlApp As Excel.Application
Dim xlSh, xlSh2, xlSh3, xlSh4 As Excel.Worksheet
Dim objWkb As Workbook
Dim GDosyaDizin As String
Dim rs, rsg As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim qdf As QueryDef
Dim GSayi As Integer
Dim GUyari As String
Dim SX As Integer
Dim Sql As String
Dim GGRup1, GGRup2, GGRup3 As String
Dim GToplam, GTopSayi As Integer


GDosyaDizin = CurrentProject.Path & "\Kurumlar_Excel.xlsx"

Set xlApp = New Excel.Application
SX = 0
xlApp.Visible = True
Set objWkb = xlApp.Workbooks.Add


SQL = "SELECT * FROM [srg_kurumlist] "
Set rsg = CurrentDb.OpenRecordset(SQL)

Do Until rsg.EOF = True
SX = SX + 1
   Set qdf = CurrentDb.QueryDefs("srg_hastalistesi")
   qdf![Forms!Izin_Raporu!DONEMI] = [Forms]![Izin_Raporu]![DONEMI]
   qdf![Forms!Izin_Raporu!UNVAN] = rsg![KURUM ADI]
   
   Set rs = qdf.OpenRecordset()
   
   intMaxCol = rs.Fields.Count
   
If rs.RecordCount = 0 Then

   GUyari = GUyari & rsg![KURUM ADI]
   
Else
     
   
    Set xlSh = objWkb.Sheets.Add
    xlSh.Name = Left(Replace(rsg![KURUM ADI], " ", "_"), 30)

       rs.MoveLast:    rs.MoveFirst
       intMaxRow = rs.RecordCount
           With xlSh
               .Range("A1").ColumnWidth = "6"
               .Range("B1").ColumnWidth = "18"
               .Range("C1").ColumnWidth = "35"
               .Range("D1").ColumnWidth = "15"
               .Range("E1").ColumnWidth = "15"
               .Range("F1").ColumnWidth = "17"
               .Range("G1").ColumnWidth = "16"
               .Range("A3") = "SIRA NO"
               .Range("B3") = "TC KİMLİK NO"
               .Range("C3") = "AD SOYAD"
               .Range("D3") = "MUAYENE TAR"
               .Range("E3") = "FATURA NO"
               .Range("F3") = "FATURA TAR"
               .Range("G3") = "TOPLAM"
               .Range("A3:G3").Select
               
               xlApp.Selection.Font.Bold = True
               xlApp.Selection.HorizontalAlignment = xlCenter
               xlApp.Selection.VerticalAlignment = xlCenter
               xlApp.Selection.Font.Bold = True
               xlApp.Selection.RowHeight = 50
               xlApp.Selection.WrapText = True
               
               .Range("A2:G2").Select
               
               .Range("A2") = rsg![KURUM ADI]
               
               xlApp.Selection.Font.Bold = True              
               xlApp.Selection.HorizontalAlignment = xlCenter
               xlApp.Selection.VerticalAlignment = xlCenter
               xlApp.Selection.Orientation = 0
               xlApp.Selection.ShrinkToFit = False
               xlApp.Selection.WrapText = True
               xlApp.Selection.MergeCells = True
               xlApp.Selection.RowHeight = 42
               
               .Range("B4").CopyFromRecordset rs            
               .Range("F4:G" & rs.RecordCount + 4 & "").NumberFormat = "#,##0.00 $"
               .Range("F" & rs.RecordCount + 6 & "") = "TOPLAM"          
               .Range("B" & rs.RecordCount + 6 & "") = "Özet " & "'KURUM ADI' = " & rsg![KURUM ADI] & " (" & rs.RecordCount & " " & IIf(rs.RecordCount = 1, "ayrıntı kaydı", "ayrıntı kayıtlar") & ")"
               
               GToplam = 0
               
               For GTopSayi = 4 To rs.RecordCount + 4
               
                   GToplam = GToplam + .Range("G" & GTopSayi & "")
               
               Next GTopSayi
               
               .Range("G" & rs.RecordCount + 6 & "") = GToplam
               .Range("A1:G" & rs.RecordCount + 8 & "").Select
               
               xlApp.Selection.VerticalAlignment = xlCenter
               xlApp.Selection.HorizontalAlignment = xlCenter

               xlApp.Selection.Font.Name = "Arial"
               xlApp.Selection.Font.Size = 11
               
               .Range("C4:C" & rs.RecordCount + 4 & "").Select
               xlApp.Selection.HorizontalAlignment = xlLeft

               .Range("B" & rs.RecordCount + 6 & "").Select
               
               xlApp.Selection.HorizontalAlignment = xlLeft

               .Range("A3:G" & rs.RecordCount + 3 & "").Borders.Weight = xlThin
               
               For GSayi = 1 To intMaxRow
               .Range("A" & GSayi + 3) = GSayi
               Next
               
               .Range("A1").Select
               
       End With
     

       xlSh.PageSetup.Orientation = xlLandscape
       xlApp.PrintCommunication = False
       xlSh.PageSetup.FitToPagesWide = 1
       xlSh.PageSetup.FitToPagesTall = True
       xlApp.PrintCommunication = True
       

 End If
 

rsg.MoveNext
Loop
 
 
For Each xlSh In objWkb.Worksheets
If InStr(1, xlSh.Name, "Sayfa") = 1 Then
objWkb.Worksheets(xlSh.Name).Delete
End If
Next xlSh

 

objWkb.SaveAs GDosyaDizin

Set xlSh = Nothing
Set xlApp = Nothing


If Len(GUyari) > 0 Then

MsgBox (GUyari & " Sayfası Veri Olmadığı İçin Oluşturulmadı")

End If

Excele aktarma ile ilgili yapabileceğim bundan ibaret.
Cevapla
#11
Sayın ozanakkaya hocam emeğine sağlık. Teşekkür ederim.
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task