Kayıtları Excele Aktarma

1 2 3
07/10/2022, 12:07

atoykan

Recordsetlerinizi ilgili aya göre filtrelenmiş olarak oluşturun
07/10/2022, 12:18

berduş

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
07/10/2022, 13:14

angelos

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
07/10/2022, 13:21

berduş

Siz kodu nereye yazdınız?
Onlar zaten forumunuzdaki acilir kutu isimler
07/10/2022, 13:22

angelos

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
07/10/2022, 13:28

angelos

Ç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
1 2 3