2007 Raporu Excele Aktarma

Sayın ozanakkaya hocam referans ekledim o kısımı hallettikten sonra ikinci hatayı verdi.

Merhaba, toplam kısmındaki sorun için, kod içerisindeki

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

kodunu iptal ederek deneyiniz.

ozanakkaya hocam özür dilerim ben size yanlış izah ettim. Alt taraftaki toplamı getirmiyor diyecektim. Yani her kurumun kendi genel toplamı.

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.

Sayın ozanakkaya hocam emeğine sağlık. Teşekkür ederim.