Accessten Excel E

1 2 3
11/11/2019, 18:13

ferdiqq

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.
11/11/2019, 18:36

berduş

Isteginizi biraz daha ayrıntılı ifade edebilir mısınız?
11/11/2019, 22:46

ferdiqq

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
11/11/2019, 23:33

berduş

Amacininiz butona her bastiginizda verilerinizi ayni Excel dosyasinda yeni bir Excel sayfasina mi kaydetmek?
12/11/2019, 00:29

ferdiqq

(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
12/11/2019, 00:55

berduş

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