Option Compare Database



Private Sub AKTAR_Click()

' REFERANSLARDAN MİCROSOFT Excel ... OBJECT LİBRARY TANIMLAMINIZ GEREKİYOR..

Dim Exapp As Excel.Application

Dim rs As Recordset

Dim yol As String

Dim x As Long

On Error Resume Next

Set Exapp = GetObject("", "excel.application")

If Err.Number <> 0 Then

  Err.Clear

        Set Exapp = CreateObject("Excel.Application")

End If

    On Error GoTo Error_Handler

    

'exel yol tanımlıyoruz..

yol = CurrentProject.Path & "\gonderilen_yer.xlsx"

'exceli açarak yükler.. false derseniz.. exceli açmadan yükler.. size kalmış

Exapp.Visible = True

Exapp.Workbooks.Open yol



'eski Excel verileri siliyoruz...

With Exapp

          .Range("a5", .Range("a5").End(xlDown).End(xlDown).End(xlToRight)).Select

          .Range("a5", .Range("a5").End(xlDown).End(xlDown).End(xlToRight)).Delete

          .Range("a5").Select

End With



'rapor sorgusunu açılıyor...

Set rs = CurrentDb.OpenRecordset("görevlendirme_icmal")



x = 5

Do While Not rs.EOF



With Exapp

    .Cells(x, 1) = rs("il")          ' 1 A KOLONU

    .Cells(x, 2) = rs("İLÇE")            '2 B KOLONUDUR

    .Cells(x, 3) = rs("GÖREV BAŞLAMA")

    .Cells(x, 4) = rs("PERSONEL SAYISI")

    .Cells(x, 5) = rs("AA")

    .Cells(x, 6) = rs("BB")

    .Cells(x, 7) = rs("SORUMLU TEL")

End With

rs.MoveNext

x = x + 1

Loop

'SORGUYU KAPATIYORUZ..

rs.Close

'İŞLEMİ BİTİRİYORUZ.. VE ÇIKIYORUZ..

Exit Sub



Error_Handler:

Exapp.ActiveWorkbook.Close True

Exapp.Workbooks.Close

Exapp.Quit

Set Exapp = Nothing

Resume 0



End Sub

Merhaba hocalarım,  o kadar örnek inceledim sonunda bunu buldum düzenledim biraz işime yaradı ama, aynı kitapta 2 syfaya, 3. sayafaya da başka butonlarla veri aktarmam lazım bubun gibi   bunu üzerinde nasıl bir ekleme yapılmalı yardımcı olabilrimisiniz.

Isteginizi biraz daha ayrıntılı ifade edebilir mısınız?

hocam birçok örnek indirdim  içlerinden bunu uyarlayabildim kendi projeme..    bu kod  bende araç tablosunu şablonu olan bir araç excelinin 4 satırından ihitbaren yazıyor kısmen işimi gördü. ancak ben yarın yine yazdıracağım  ozaman bana aynı excelin içinde yeni bir sayfa açması lazım. bunu yapamadım.   birde ek olarak 3 tane sorguyu böyle koddaki gibi tek bir Excel sayfasının ayrı ayrı yerlerine yazdırabliriz değilmi oda gerekli

Amacininiz butona her bastiginizda verilerinizi ayni Excel dosyasinda yeni bir Excel sayfasina mi kaydetmek?

(11/11/2019, 23:33)berduş yazdı: Amacininiz butona her bastiginizda verilerinizi ayni Excel dosyasinda yeni bir Excel sayfasina mi kaydhocam tam olarak istediğim 

hocam o şekilde işimi görüyor, dosyaismi olarak date kullanılırsa her gün için aynı excelde yenir bir sayfa açıp oraya kaydedecek.

ancak şablonu bozmadan yapıştırma yapması gerekiyor, bu örnekte tek bir sorguyu aktarıyor, ben 3 tane sorgu aktaracağım , x değişkenine ilave olarak y ve z tanımlayıp kodu kopyala yapıştır yapıp düşey ve yatay sırayı değiştirip yaptım onu. 3 tablo tek excele geliyor.. 

.rangeli satırları da sildim   dim r as range yapıp   set r=cells(5,27)  r.delete kullanarak sadece belirli alanı sildim çünkü 3 tane sorgu var diğer sorguların şablonu bozuluyor ama buda bir çalışıyor bir çalışmıyor.

şuan eksiklerim şablonu açınca üzerine değil aynımexcel dosyayısında şablonlu şekilde yeni sayfaya yazsın istiyorum.  sitede arama yapacak arkadaşlar içinde örnek uygulamayı yükleyip paylaşmak isityorum faydalı olacaktır.


KODUN DENEMEDEKİ SON HALİ

Private Sub AKTAR_Click()
' REFERANSLARDAN M?CROSOFT Excel ... OBJECT L?BRARY TANIMLAMINIZ GEREK?YOR..
Dim Exapp As Excel.Application
Dim rs As Recordset
Dim yol As String
Dim x As Long
Dim r As Range
On Error Resume Next
Set Exapp = GetObject("", "excel.application")
If Err.Number <> 0 Then
  Err.Clear
        Set Exapp = CreateObject("Excel.Application")
End If
    On Error GoTo Error_Handler
   
'exel yol tan?ml?yoruz..
yol = CurrentProject.Path & "\yeni.xlsx"
'exceli a?arak y?kler.. false derseniz.. exceli a?madan y?kler.. size kalm??
Exapp.Visible = True
Exapp.Workbooks.Open yol
'eski Excel verileri siliyoruz...
''With Exapp
         '' .Range("a5", .Range("a5").End(xlDown).End(xlDown).End(xlToRight)).Select   bunlar iptal artık çünkü alan belirtemedeim onun yerine aşağıdaki kodu kullnadım
         '' .Range("a5", .Range("a5").End(xlDown).End(xlDown).End(xlToRight)).Delete
       ''   .Range("a5").Select
''End With


With Exapp
Set r = Cells(5, 27)
r.Delete
End With



'rapor sorgusunu a??l?yor...
Set rs = CurrentDb.OpenRecordset("sorgu2")
x = 5
Do While Not rs.EOF
With Exapp
    .Cells(x, 1) = rs("il")          ' 1 A KOLONU
    .Cells(x, 2) = rs("?L?E")            '2 B KOLONUDUR
    .Cells(x, 3) = rs("G?REV BA?LAMA")
  
End With
rs.MoveNext
x = x + 1
Loop
Set rs = CurrentDb.OpenRecordset("sorgu1")
y = 5
Do While Not rs.EOF
With Exapp
    .Cells(y, 7) = rs("il")          ' 1 A KOLONU
    .Cells(y, 8) = rs("?L?E")            '2 B KOLONUDUR
    .Cells(y, 9) = rs("G?REV BA?LAMA")
  
End With
rs.MoveNext
y = y + 1
Loop

Set rs = CurrentDb.OpenRecordset("sorgu1")
z = 30
Do While Not rs.EOF
With Exapp
    .Cells(z, 5) = rs("il")          ' 1 A KOLONU
    .Cells(z, 6) = rs("?L?E")            '2 B KOLONUDUR
    .Cells(z, 7) = rs("G?REV BA?LAMA")
  
End With
rs.MoveNext
z = z + 1
Loop

'SORGUYU KAPATIYORUZ..
rs.Close
'??LEM? B?T?R?YORUZ.. VE ?IKIYORUZ..
Exit Sub
Error_Handler:
Exapp.ActiveWorkbook.Close True
Exapp.Workbooks.Close
Exapp.Quit
Set Exapp = Nothing
Resume 0
End Sub

Çalışmanızı eklemeniz mümkün mü?
1 - aynı gün içinde birden fazla kodu calistirirsaniz ne olacak eski verileri silip yeniden mi ekleyecek yoksa bugüne ait kayıt var yeniden eklenemez mi diyecek?
2 - bu 3 sorguyu birleştirmek daha uygun olmaz mı?
3 - DoCmd.TransferSpreadsheet yöntemi işinize yaramıyor mu?
Not: bilgisayar erişimim kısıtlı  olduğundan geç cevap verebilirim
Yeni sayfa oluşturma kodu aşağıdaki gibi düzenlenebilir

Dim objexcel As Excel.Application 

Dim wbexcel As Excel.Workbook 

Dim objsheet As Excel.Worksheet 

Set objexcel = New Excel.Workbook 

Set wbexcel = objexcel.Workbooks.Open(FileName) ' ActiveWorkbook.Sheets.Add ("Test") 

Set objsheet = wbexcel.Sheets.Add 

objsheet.Name = date