excele gönderirken şartlı gönderme

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"

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?