Skip to main content

AccessTr.neT


excele gönderirken şartlı gönderme

excele gönderirken şartlı gönderme

Çözüldü #7
kusura bakmayın,
excele gönder butonunun
tıklandığında olayına,
aşağıdaki kodu kopyalamak yeterli.


Dim dbSurucu As String
Dim dbDosya As String
Dim dbExcel As Object
Dim fdExcel As Object
Dim vbExcel As Object
Dim vbBook As Object
Dim vbSheet As Object

Dim rsExcel As New Recordset
Set vbExcel = CreateObject("Excel.Application")
Set vbBook = vbExcel.Workbooks.Add

SORGU = "SELECT SIPARIS_LISTESI.MUSTERI, PARTILENENLER.PARTI_NO, PARTILENENLER.IRS_KODU, SIPARIS_LISTESI.RENK_NO, SIPARIS_LISTESI.RENK, SIPARIS_LISTESI.CINSI, PARTILENENLER.PAR_KG, PARTILENENLER.MAK_NO, PARTILENENLER.DURUMU, PARTILENENLER.DURUM_ZAMANI FROM SIPARIS_LISTESI INNER JOIN PARTILENENLER ON SIPARIS_LISTESI.SIPARISNO = PARTILENENLER.SIPARIS_NO WHERE (((SIPARIS_LISTESI.MUSTERI)=[SIPARIS_LISTESI].[MUSTERI]) AND ((PARTILENENLER.PARTI_NO)=[PARTILENENLER].[PARTI_NO]) AND ((SIPARIS_LISTESI.RENK_NO)=[SIPARIS_LISTESI].[RENK_NO]) AND ((SIPARIS_LISTESI.CINSI)=[SIPARIS_LISTESI].[CINSI]) AND ((PARTILENENLER.DURUMU)='Sevk Edildi') AND ((PARTILENENLER.DURUM_ZAMANI)>=#5/16/2014# And (PARTILENENLER.DURUM_ZAMANI)<=#5/16/2014#));"

rsExcel.Open Me.Liste60.RowSource, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

Set vbSheet = vbBook.Worksheets(1)

Dim fdArray, fdCount, rdCount
fdCount = 0
For Each fdExcel In rsExcel.Fields
fdCount = fdCount + 1
If fdCount > 1 Then
fdArray = fdArray & "<,>" & fdExcel.Name
Else
fdArray = fdExcel.Name
End If
Next

' Excel Belgesine Başlıklar Aktarılıyor
With vbSheet.Range("A1")
.Resize(1, fdCount) = Split(fdArray, "<,>")
.Resize(1, fdCount).Font.Color = &HFF0000
End With

rdCount = 1
While Not rsExcel.EOF
rdCount = rdCount + 1
fdCount = 0
For Each fdExcel In rsExcel.Fields
fdCount = fdCount + 1
vbSheet.Cells(rdCount, fdCount) = fdExcel.Value
Next

rsExcel.MoveNext
'x:

Wend
vbSheet.Cells.Select
vbSheet.Cells.EntireColumn.AutoFit
vbSheet.Range("A1").Select

'Excel Belgesi kaydediliyor.
vbBook.SaveAs "Sipariş Stok Listesi " & Date & ".xls"
vbExcel.Quit

Set dbExcel = Nothing
Set rsExcel = Nothing
Set vbExcel = Nothing
Set vbBook = Nothing
Set vbSheet = Nothing

MsgBox "Liste Belgelerim Klasörüne aktarılmıştır"
husem, proud to be a member of AccessTr.neT since 08-03-2009.
Cevapla
#8
sayın @husem bey paylaştığınız örneğe benzer bir çalışma yapmaya çalışıyorum fakat örneğinizi incelediğimde Compile Error: İnvalid Use of New keyword hatası veriyor. Nedeni nedir acaba?
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task