Skip to main content

AccessTr.neT M.


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

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


kodunu iptal ederek deneyiniz.

"Boş Örnek Eklerim, Yapıp Verirler" demeyin, örneğinizi hazırlayın.
Komplike kod talebiniz var ise İletişim bağlantısından bize ulaşın. 
Cebelleşmezsen Öğrenemezsin. 
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

Visual Basic Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
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.

"Boş Örnek Eklerim, Yapıp Verirler" demeyin, örneğinizi hazırlayın.
Komplike kod talebiniz var ise İletişim bağlantısından bize ulaşın. 
Cebelleşmezsen Öğrenemezsin. 
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