Recordsetlerinizi ilgili aya göre filtrelenmiş olarak oluşturun
Kayıtları Excele Aktarma
excele aktarma kodunuzu aşağıdaki kodla değiştirip dener misiniz?
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
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ı
31 satırlık
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").ColumnWidth = 20
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
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
Son Düzenleme: 07/10/2022, 13:23, Düzenleyen: 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
Konuyu Okuyanlar: 1 Ziyaretçi