Kayıtları Excele Aktarma

Recordsetlerinizi ilgili aya göre filtrelenmiş olarak oluşturun

excele aktarma kodunuzu aşağıdaki kodla değiştirip dener misiniz?

Private Sub aktarexcel_Click()

Dim excl As Excel.Application

Dim KTP1 As Excel.Workbook

Dim SYF As Excel.Worksheet

Dim Sql As String

DoCmd.SetWarnings False

Dim rs1 As Recordset

    



If MsgBox("Bilgileriniz Excele Aktarılsın mı?", vbInformation + vbYesNo + vbDefaultButton1, "deneme") = vbNo Then Exit Sub





Set excl = CreateObject("Excel.Application")

With excl



      .Application.Visible = True

      .UserControl = True



End With



        Set KTP1 = excl.Workbooks.Add

        Set SFY = KTP1.Worksheets(1)

Dim ADO_RS As ADODB.Recordset



Set ADO_RS = New ADODB.Recordset

SQL = "SELECT Rs1.id, Rs1.sicil, Rs1.adsoyad, Rs1.rutbe, ""KOM"" AS İfade1, Rs0.E1, Rs0.E2, Rs0.E3, Rs0.E4, Rs0.E5, " & _

                "Rs0.E6, Rs0.E7, Rs0.E8, Rs0.E9, Rs0.E10, Rs0.E11, Rs0.E12, Rs0.E13, Rs0.E14, Rs0.E15, Rs0.E16, Rs0.E17, Rs0.E18, " & _

                "Rs0.E19, Rs0.E20, Rs0.E21, Rs0.E22, Rs0.E23, Rs0.E24, Rs0.E25, Rs0.E26, Rs0.E27, Rs0.E28, Rs0.E29, Rs0.E30, Rs0.E31, " & _

                "Rs0.CalisilanGun, Rs2.katsayi, Rs2.puan, [katsayi]*[puan] AS Gcn " & _

      "FROM tblhsp AS Rs2, PERSONEL1 AS Rs1 INNER JOIN tazminat AS Rs0 ON Rs1.id = Rs0.ADISOYADI " & _

      "WHERE (((Rs0.YIL)=" & Me.cmbYear & ") AND ((Rs0.AY)=" & Me.cmbMonth & "));"



ADO_RS.CursorLocation = adUseClient 'bu satır eklenince daha hızlı

ADO_RS.Open SQL, CurrentProject.Connection, 3, 1



'YOKLAMA KİTABINDA SAYFA OLUŞTURTURUYORUZ EĞER SAYFA VARSA AYNI İZİMDEN SONUNA 1 EKLEYEREK SAYFA OLUŞTURUR

            SyfAdi = "OPERASYON LİSTESİ"

            SyfAdiTmp = SyfAdi

            SyfNo = 0

            Do While WorksheetExists(SyfAdiTmp, KTP1) = True

            SyfNo = SyfNo + 1

            SyfAdiTmp = SyfAdi & IIf(SyfNo = 0, "", "(" & SyfNo & ")")

            Loop

            excl.Sheets.Add.Name = SyfAdiTmp

'###########################################################################################################



excl.Sheets(SyfAdiTmp).PageSetup.Orientation = xlLandscape

excl.Sheets(SyfAdiTmp).PageSetup.LeftMargin = "18" 'sol sayfa genişliği

excl.Sheets(SyfAdiTmp).PageSetup.RightMargin = "15" 'sağ sayfa genişliği

excl.Sheets(SyfAdiTmp).PageSetup.TopMargin = "15" 'üst sayfa genişliği

excl.Sheets(SyfAdiTmp).PageSetup.BottomMargin = "15" 'alt sayfa genişliği

excl.Sheets(SyfAdiTmp).PageSetup.HeaderMargin = "18" 'üst bilgi genişliği

excl.Sheets(SyfAdiTmp).PageSetup.FooterMargin = "18" 'alt bilgi genişliği

excl.Sheets(SyfAdiTmp).PageSetup.Zoom = 59



'########################################################################################################

With SYF

'Excl.Range("A:N").Font.Name = "Times New Roman"

'Excl.Range("A:N").VerticalAlignment = xlCenter 'ortaya hizalaR

'Excl.Range("A:N").HorizontalAlignment = xlCenter 'ortaya hizalar

'Excl.Range("A:N").ColumnWidth = 24 'SÜTUN GENİŞLİĞİ AYARLA

'Excl.Range("A1").RowHeight = 35 'SATIR YÜKSEKLİĞİ AYARLAR

'Excl.Range("A1").Font.size = 18 ' YAZININ KARAKTER BOYUTUNU BELİRLER

'Excl.Range("A2:N2").Font.Bold = True 'YAZIYI KALIN YAPAR

'Excl.Range("A1:N1").MergeCells = True 'Hücreler Birleştiriliyor

'Excl.Range("A1:N1").Interior.ColorIndex = 45 'HÜCRENİN ARKA PLAN RENGİ





excl.Range("A1:AN1").MergeCells = True 'Hücreler Birleştiriliyor

excl.Range("A2:AN2").MergeCells = True 'Hücreler Birleştiriliyor

excl.Range("A1") = "............... TAZMİNATI LİSTESİDİR"

excl.Range("A2") = "........................... ŞUBE MÜDÜRLÜĞÜ (                        )TARİHLERİ ARASI ........... TAZMİNATI"



excl.Range("A3") = "S/NO"

excl.Range("A:A").HorizontalAlignment = xlCenter



excl.Range("A3").VerticalAlignment = xlCenter

excl.Range("A3").HorizontalAlignment = xlCenter



excl.Range("B3") = "SİCİL"

excl.Range("B3").VerticalAlignment = xlCenter

excl.Range("B3").HorizontalAlignment = xlLeft

'excl.Range("B3:B90").HorizontalAlignment = xlCenter





excl.Range("C3") = "ADI SOYADI"

excl.Range("C3").VerticalAlignment = xlCenter

excl.Range("C3").HorizontalAlignment = xlLeft

'excl.Range("C3:C90").HorizontalAlignment = xlLeft



excl.Range("D3") = "RÜTBE"

excl.Range("D3").VerticalAlignment = xlCenter

excl.Range("D3").HorizontalAlignment = xlLeft

'excl.Range("C3:C90").HorizontalAlignment = xlLeft



excl.Range("E3") = "BİRİMİ"

excl.Range("E3").VerticalAlignment = xlCenter

excl.Range("E3").HorizontalAlignment = xlCenter

excl.Range("E3:E90").HorizontalAlignment = xlLeft





excl.Range("AK3") = "Çalışılan Gün"

excl.Range("AL3") = "KATSAYI"

excl.Range("AM3") = "PUAN"

excl.Range("AN3") = "ELE GEÇEN"





excl.Range("AK3:AN3").VerticalAlignment = xlCenter

excl.Range("AK3:AN3").HorizontalAlignment = xlCenter

'excl.Range("F3:AJ3").RowHeight = 80



excl.Range("A1:AN2").Font.Bold = True 'YAZIYI KALIN YAPAR

excl.Range("A1:AN2").VerticalAlignment = xlCenter 'ortaya hizalaR

excl.Range("A1:AN2").HorizontalAlignment = xlCenter 'ortaya hizalar

excl.Range("A1:AN2").RowHeight = 15 'SATIR YÜKSEKLİĞİ AYARLAR



excl.Range("A3:E3").Font.Bold = True 'YAZIYI KALIN YAPAR

excl.Range("A3:E3").Font.Size = 12



'excl.Range("F3:AJ3").Orientation = 90 'Metin Yönü

 excl.Range("F3") = 1

 excl.Range("F3").DataSeries _

                  Rowcol:=xlRows, _

                  Type:=xlLinear, _

                  Date:=xlDay, _

                  Step:=1, _

                  Stop:=31, _

                  Trend:=False





'seçili alanlara kenarlık ekleme kodu

excl.Range("A1:AN2").Borders.LineStyle = xlContinuous

excl.Range("A3:AN70").HorizontalAlignment = xlCenter



excl.Range("A:A").ColumnWidth = 7 'SÜTUN GENİŞLİĞİ AYARLA

excl.Range("B:B").ColumnWidth = 10 'SÜTUN GENİŞLİĞİ AYARLA

excl.Range("C
excl.Range("E:E").ColumnWidth = 7





excl.Range("F:AJ").ColumnWidth = 4



'excl.Range("AJ:AJ").ColumnWidth = 4

excl.Range("AK:AN").ColumnWidth = 10



excl.Range("F4:AJ90").HorizontalAlignment = xlCenter





On Error Resume Next

' Excel e veri aktarma kodları

 excl.Range("A4").CopyFromRecordset ADO_RS

i = ADO_RS.RecordCount + 4

ADO_RS.Close



excl.Range("A3", "AN" & i - 1).Borders.LineStyle = xlContinuous



End With

excl.Visible = True

Set excl = Nothing





DoCmd.SetWarnings True



End Sub

---

aşağıda bazı kodların daha pratik halleri gösterilmiştir
döngüyle aktarmak yerine toplu olarak aktarma kodunu kullanmanız işlemi hızlandırır

      Set rs0 = CurrentDb.OpenRecordset("tazminat")

        Set Rs2 = CurrentDb.OpenRecordset("tblhsp")

        Set rs1 = CurrentDb.OpenRecordset("PERSONEL1")

        Do Until rs1.EOF

      

        excl.Cells(i, "A") = rs1(0)

  ....

        excl.Cells(i, "AN") = Rs2(1) * Rs2(2)

        

      i = i + 1

      

  rs1.MoveNext

  rs0.MoveNext

      

    Loop

  

rs1.Close

50 satırlık döngülü kod yerine aşağıdaki kod daha pratik
en azından döngü olmadığından daha hızlı

Dim ADO_RS As ADODB.Recordset



Set ADO_RS = New ADODB.Recordset

SQL = "SELECT Rs1.id, Rs1.sicil, Rs1.adsoyad, Rs1.rutbe, ""KOM"" AS İfade1, Rs0.E1, Rs0.E2, Rs0.E3, Rs0.E4, Rs0.E5, " & _

                "Rs0.E6, Rs0.E7, Rs0.E8, Rs0.E9, Rs0.E10, Rs0.E11, Rs0.E12, Rs0.E13, Rs0.E14, Rs0.E15, Rs0.E16, Rs0.E17, Rs0.E18, " & _

                "Rs0.E19, Rs0.E20, Rs0.E21, Rs0.E22, Rs0.E23, Rs0.E24, Rs0.E25, Rs0.E26, Rs0.E27, Rs0.E28, Rs0.E29, Rs0.E30, Rs0.E31, " & _

                "Rs0.CalisilanGun, Rs2.katsayi, Rs2.puan, [katsayi]*[puan] AS Gcn " & _

      "FROM tblhsp AS Rs2, PERSONEL1 AS Rs1 INNER JOIN tazminat AS Rs0 ON Rs1.id = Rs0.ADISOYADI " & _

      "WHERE (((Rs0.YIL)=" & Me.cmbYear & ") AND ((Rs0.AY)=" & Me.cmbMonth & "));"



ADO_RS.CursorLocation = adUseClient

ADO_RS.Open SQL, CurrentProject.Connection, 3, 1

 excl.Range("A4").CopyFromRecordset ADO_RS

31 satırlık

excl.Range("F3") = 1

excl.Range("G3") = 2

excl.Range("H3") = 3

excl.Range("I3") = 4

excl.Range("J3") = 5

excl.Range("K3") = 6

excl.Range("L3") = 7

excl.Range("M3") = 8

excl.Range("N3") = 9

excl.Range("O3") = 10

excl.Range("P3") = 11

excl.Range("Q3") = 12

excl.Range("R3") = 13

excl.Range("S3") = 14

excl.Range("T3") = 15

excl.Range("U3") = 16

excl.Range("V3") = 17

excl.Range("W3") = 18

excl.Range("X3") = 19

excl.Range("Y3") = 20

excl.Range("Z3") = 21

excl.Range("AA3") = 22

excl.Range("AB3") = 23

excl.Range("AC3") = 24

excl.Range("AD3") = 25

excl.Range("AE3") = 26

excl.Range("AF3") = 27

excl.Range("AG3") = 28

excl.Range("AH3") = 29

excl.Range("AI3") = 30

excl.Range("AJ3") = 31

yerine

excl.Range("F3") = 1

 excl.Range("F3").DataSeries _

                                Rowcol:=xlRows, _

                                Type:=xlLinear, _

                                Date:=xlDay, _

                                Step:=1, _

                                Stop:=31, _

                                Trend:=False

cmbyear ve cmbmounth parametre değeri istiyor açılmıyor varsayılan değer yazmışsınız siz zaten ekstra yapmam gereken birşey varmı acaba merakla sonucu görmek istiyorum. Ayrıca emek vermişsiniz çok teşekkür ederim

Siz kodu nereye yazdınız?
Onlar zaten forumunuzdaki acilir kutu isimler

excele aktar butonu tıklandığında kodunu sizin verdiğiniz kod ile değiştirdim sadece

---

(07/10/2022, 13:22)angelos yazdı: excele aktar butonu tıklandığında kodunu sizin verdiğiniz kod ile değiştirdim sadece

Özür diliyorum kodu tamamen yapıştırınca Private Sub aktarexcel_Click() iki tane olmuş açıldı inceliyorum

Çok teşekkür ediyorum harika çalışıyor. Hakkınız helal edin uğraştırdım sizi, geçici tablo oluşturmadan hallettiniz yıl ve ay bazında sorgu oluşturarak heralde ben bu sorguyu günlerce yazamazdım çok fırın ekmek yememiz lazım daha. Tekrar teşekkürler