AccessTr.neT

Buda benden olsun Polisleri severim

hocam çok teşekkürler makbule geçti yalnız tarih kriterini sorması lazım birde üst bilgisini atayıp renkli yapabilirmiyiz acaba...

ben tarih sormasın diye SRGO-c isminde yeni sorgular yapmıştım onları kullandım eger sen tarih sormasını istiyorsan kodlardki misal SRG0-c yi SRG0,digerini SRG1 gbi degiştir yani senin asıl sorgularını kullan ,renk işini ise bilmiyorum kolay gelsin

hocam çok teşekkür ederim seruz hocanın bu örnek formülünü uyarlayabilirmiyiz acaba?
Option Compare Database 'Use database order for string comparisons
Option Explicit
Dim ExcelDosyasi As Object

Private Sub BasTarihi_AfterUpdate()
Me.BitTarihi = Me.BasTarihi + 6
End Sub

Private Sub btn_EXCEL_Click()
On Error GoTo Err_btn_EXCEL_Click
Dim Rs As New ADODB.Recordset
Dim i, BasSatirSayisi, SatirSayisi, SutunSayisi As Integer

If IsNull(Me.Secilen_MAHALLE) Then Exit Sub

'---------------------------------------------------------------------------------------------------------
'Excel açılıyor ve başlıklar ayarlanıyor
'---------------------------------------------------------------------------------------------------------
Set ExcelDosyasi = CreateObject("Excel.Application")
With ExcelDosyasi
.Application.Visible = True
.UserControl = True
.Workbooks.Add
.Sheets(1).Name = Me.Secilen_MAHALLE
End With

'---------------------------------------------------------------------------------------------------------
'Tablo açılıyor
'---------------------------------------------------------------------------------------------------------
DoCmd.SetWarnings False
DoCmd.OpenQuery "HAFTALIK_Yarat"
DoCmd.SetWarnings False

'---------------------------------------------------------------------------------------------------------
'Tablo açılıyor
'---------------------------------------------------------------------------------------------------------
Rs.Open "HAFTALIK_Capraz", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
SutunSayisi = Rs.Fields.Count
BasSatirSayisi = 3
SatirSayisi = BasSatirSayisi

'Başlıklar Oluşturuluyor
With ExcelDosyasi
.Sheets(1).Select
.ActiveWindow.DisplayGridlines = False
.Cells(1, 2) = Me.Secilen_MAHALLE & " BELDESİ HAFTALIK ÇALIŞMA PROGRAMI"
.Cells.Font.Name = "Arial"
.Cells.Font.Size = 20

'Kayıt yoksa çıkılıyor
If Rs.RecordCount = 0 Then
.Cells(2, 2) = "Kayıt bulunamadı"
Rs.Close
Exit Sub
End If

'Sütun Başlıkları atanıyor, Tarih olan alanların formatı değiştiriliyor.
For i = 1 To SutunSayisi
If Rs.Fields(i - 1).Name = "Saat" Then
.Cells(SatirSayisi, i + 1) = Rs.Fields(i - 1).Name
Else
.Cells(SatirSayisi, i + 1) = CVDate(Rs.Fields(i - 1).Name)
.Cells.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
End If
Next i
End With

'---------------------------------------------------------------------------------------------------------
' Kayıtlar Okunuyor ve Yazılıyor
'---------------------------------------------------------------------------------------------------------
Do Until Rs.EOF
With ExcelDosyasi
SatirSayisi = SatirSayisi + 1

'Satır Detayı
For i = 1 To SutunSayisi
.Cells(SatirSayisi, i + 1) = Rs.Fields(i - 1)
Next i

'Sonraki Kayıt
Rs.MoveNext
End With
Loop
Rs.Close

'-----------------------------------------------------------------------
' Sütun Formatları
'-----------------------------------------------------------------------
With ExcelDosyasi
.Range(.Cells(3, 2).Address, .Cells(SatirSayisi, SutunSayisi + 1).Address).HorizontalAlignment = xlCenter
.Cells.EntireColumn.AutoFit
.Columns("A").EntireColumn.ColumnWidth = 1
.Columns("B").EntireColumn.ColumnWidth = 11

' Çerçeve İşlemleri
.Range(.Cells(3, 2).Address, .Cells(SatirSayisi, SutunSayisi + 1).Address).Select

.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

' Yazıcı Ayarları
With .ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
.ActiveSheet.PageSetup.PrintArea = ""
With .ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = .Application.InchesToPoints(0.4)
.RightMargin = .Application.InchesToPoints(0.4)
.TopMargin = .Application.InchesToPoints(0.4)
.BottomMargin = .Application.InchesToPoints(0.4)
.HeaderMargin = .Application.InchesToPoints(0.4)
.FooterMargin = .Application.InchesToPoints(0.4)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
End With
'-----------------------------------------------------------------------

ExcelDosyasi.Range("A1").Select

Set ExcelDosyasi = Nothing

Exit_btn_EXCEL_Click:
Exit Sub

Err_btn_EXCEL_Click:
MsgBox Err.Description
Resume Exit_btn_EXCEL_Click

End Sub

Sayın Abdulvahap
Bu birşakaydı, bizimle Mevlüt(Celoyce) ve Seruz arasında.. Sizinle en ufak bir ilgisi yok. O genelde " P ROĞRAM" yazdığı için doğrusu da PROGRAM olduğu için ona takılıyoruz.

Yalnız bu arada bu sitenin bir farkını belirteyim. Siz burada sayın Taruz'a teşekkür edebiliyorsunuz ama sayın Taruz sitesinde başta benim adım olmak üzere bu sitenin adının bile geçmesine dayanamıyor. Bununla ilgili yakın zamanda birden fazla örnek vardır ki sayın Taruz sitesinden bu ve benzeri mesajları silmiştir. Olsun.. BizMEvlana gibiyiz demiştik. Onu da böyle seviyoruz)

vahap bey exel konusunda seruz hocadan yardım isteyin ,ben pek anlamam