Excele aktar

8

86126

Katılım
24 Aralık 2006
Mesajlar
232
Excel Vers. ve Dili
2007 ingilizce
arkadaşlar elimde aşağıdaki şekilde kod var
Private Sub Komut79_Click()
On Error GoTo Err_aktar

Dim Klasor As String
Klasor = CurrentProject.Path & "\SONUÇLAR.xlsx"
If MsgBox("Verileri Excele aktarmak istiyor musunuz? ", 36, "SONUÇLAR.xlsx 'ye aktarılacak") = 6 Then

DoCmd.TransferSpreadsheet acExport, 8, "ARSAYGÖREKAZA TÜRLERİ SON", Klasor, True, "ARSAYGÖREKAZA TÜRLERİ SON"
DoCmd.TransferSpreadsheet acExport, 8, "SÜRÜCÜSAYISI", Klasor, True, "SÜRÜCÜSAYISI"
DoCmd.TransferSpreadsheet acExport, 8, "asli kusurlar son", Klasor, True, "asli kusurlar son"
DoCmd.TransferSpreadsheet acExport, 8, "HAVADURUMUSON", Klasor, True, "HAVADURUMUSON"
DoCmd.TransferSpreadsheet acExport, 8, "GÜNDURUMUSON", Klasor, True, "GÜNDURUMUSON"
DoCmd.TransferSpreadsheet acExport, 8, "YOLUNKAPLAMADURUMUSON", Klasor, True, "YOLUNKAPLAMADURUMUSON"
DoCmd.TransferSpreadsheet acExport, 8, "KAZAYAETKİEDENARAÇ AKSAMLARI SON", Klasor, True, "KAZAYAETKİEDENARAÇ AKSAMLARI SON"
DoCmd.TransferSpreadsheet acExport, 8, "ARAÇ CİNSLERİ SON", Klasor, True, "ARAÇ CİNSLERİ SON"
DoCmd.TransferSpreadsheet acExport, 8, "YOLUN YÜZEYİSON", Klasor, True, "YOLUN YÜZEYİSON"

MsgBox "Aktarma işlemi tamamlandı. Sonuçlar Excel sayfasını açıp sonuçları görebilirsiniz .Saygılar", 0, "VERİ AKTARIMI"

Exit_aktar:
Exit Sub

Err_aktar:
MsgBox Error$
Resume Exit_aktar

End If
End Sub

koda göre excele verileri aktara biliyorum. ancak benim isteğim tek sayfaya verileri göndermek. excel de sayfa 1 de a1 den başlayarak boş bulduğu satır ve sütuna verileri aktarmak yardımlarınızı bekliyorum.
veya sayfa 1 de belirtiğim aralıklara ilgili sorguları aktarabilirmiyiz.
 
M

modalı

Katılım
25 Aralık 2005
Mesajlar
4,160
Excel Vers. ve Dili
MS Office 2010 Pro Türkçe
Sayın 86126,

Bu iş biraz karışık. Anlatılarak yapılabileceğini zannetmiyorum. Ama yinede bazı kodları vereyim, ancak bunun dişinda bir yardımcı tabloya da ihtiyacınız olacak:

Kod: 
Function fnTabletoExcel()

'Yeni bir excel uygulaması yaratıp tablo içindeki verileri
'excel uygulamasının belirli sayfasından belirli hücreden
'başlamak üzere kaydedeceğiz

Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim Name As String
Dim tarih As String

Set xlApp = CreateObject("Excel.Application")

    'Excel uygulamasının görünür hale getirmek için True değerini aktif hale getiriyoruz.
    'xlApp.Visible = True
        
    'Name de belirttiğimiz uygulamayı açıyoruz.
    tarih = Date
    tarih = Format(tarih, "dd.mm.yyyy")
    Name = CurrentProject.Path & "\" & tarih & ".xls"

    'Yeni bir kitap ve sayfa ekliyoruz.
    Set xlWB = xlApp.Workbooks.Add
    Set xlWS = xlWB.ActiveSheet
    xlWS.Application.DisplayAlerts = False
    

Dim rec As Recordset, db As Database, i%
Dim looper As Integer
Dim intCounter As Integer

    
    Set db = CurrentDb
    Set rec = db.OpenRecordset("qry_Malzeme_Giris") 'qry_Malzeme_Giris adlı sorgumuzu açıyoruz.

'Kayıtları kontrol edip kayıt yoksa fonksiyonun işleyişini durduruyoruz
If rec.EOF Then rec.Close: Exit Function

rec.MoveLast: rec.MoveFirst 'Bütün kayıtları çağırıyoruz

'Alan adlarını 8. satır 5. sütundan başlayarak sağa doğru yazdırıyoruz.
For i = 0 To (rec.Fields.Count - 1)
    xlWS.Cells(8, (i + 5)) = rec(i).Name
Next i

'Dinamik olarak alanları oluşturuyoruz
rec.MoveFirst
 
'Değerleri yazdırıyoruz
For i = 2 To rec.RecordCount + 1
    For looper = 0 To (rec.Fields.Count - 1)
        xlWS.Cells(i + 7, (looper + 5)) = rec(looper) 'veriler 9. sütundan başlayacağına göre i=2 için 7 yazarız
        'aynı şekilde looper=0 olduğundan 5. sütun için looper değerine 5 ekleriz
    Next looper
rec.MoveNext
Next i

    
        
    xlWS.Name = "Malzeme Girişleri" 'Sayfamızın adını Malzeme Girişleri yapıyoruz.
    xlWS.Range("e6:j6").Merge 'e6 hücresinden j6 hücresine kadar olan hücreleri birleştiriyoruz
    xlWS.Range("e6") = tarih & " HAMMADDE-AMBALAJ STOK GİRİŞ TAKİP FORMU" 'e6 hücresine tarihi ve başlığı yazıyoruz.
    'Başlığı biçimlendiriyoruz
    xlWS.Range("e6").VerticalAlignment = xlCenter
    xlWS.Range("e6").HorizontalAlignment = xlCenter
    xlWS.Range("e6").Font.Size = 10
    xlWS.Range("e6").Font.Bold = True
    
    'j sütununu tarih formatına çeviriyoruz.
    xlWS.Range("j8:j" & [j65532].End(xlUp).Row).Select
    Selection.NumberFormat = "dd.mm.yyyy"
    
    'Bütün hücrelere kenarlık ekliyoruz.
    xlWS.Range("e8:j" & [e65532].End(xlUp).Row).Select
    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
 xlWS.Range("a1").Activate

    'Otomatik genişletme yapıyoruz.
    xlWS.Columns("e:j").EntireColumn.AutoFit
    
'Excel uygulamamızı kaydediyoruz
xlWB.SaveAs Name

'excel sayfasını görünmez yapıyoruz
xlApp.Visible = False
'Çıkış
xlWS.Application.Quit
MsgBox "Transfer İşlemi Başarıyla Gerçekleştirildi!"

End Function
Ayrı bir modülde.

Kod: 
Function fnCellRefConv(strInputCell As Integer) As String
'Bu fonksiyon SSRef tablosunu açıp (Sayfa yayılma referansı)
've tablodaki numaraları excel sayfasının hücrelerine atıyor
'tablodan bağlantı kelimelerini sağlıyor

Dim db As Database
Set db = CurrentDb

Dim rst As Recordset
Set rst = db.OpenRecordset("tblSSRef")

Dim looper As Integer
looper = 0

rst.MoveFirst

Do While Not rst.EOF
    If looper = strInputCell Then
        rst.MovePrevious
        fnCellRefConv = rst(1)
        rst.Close
        Set rst = Nothing
        Exit Function
    End If
    looper = looper + 1
    rst.MoveNext
Loop

rst.Close
Set rst = Nothing


End Function
ve en sonunda: tblSSRef içinde iki alanımız var:

CellD_Auto bunda 1 den 52 ye kadar sayılar ve

CellD_Ref
tblSSRef tblSSRef CellID_Ref A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ

Bir örnek de ekliyorum.

İyi çalışmalar
 

Ekli dosyalar

K

karaayhan

Katılım
16 Kasım 2005
Mesajlar
1,090
Excel Vers. ve Dili
Access 2002
zaten üstad sizin anlamayacağınızı peşin olarak söylemiş ve buna rağmen zahmet ederek kodları eklemiş ya hiç access bilmiyorsunuz yada dalga geçiyorsunuz ....
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst