kapalı dosyaya veri aktarma

[fmt1976]

Merhabalar EXCEL.WEB.TR dostları Benim bir sorunum var. Eğer bu sorunu çözersem yapmış olduğum program bitecek.
Sorum şu; tahmin.xls dosyası var ve bu çalışma sayfasındaki hive sayfasını networkte bulunan \\server\wasp.xls dosyasının içine kopyalamak istiyorum wasp.xls dosyası kapalı olacak.
örnek dosyalar ektedir. yardımlarınızı bekliyorum

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub Güncelle()
[COLOR=green]'On Error Resume Next[/COLOR]
[COLOR=green]'Referanslardan Microsoft ActiveX  Data Objects 2.6 Library seçili olmalıdır.[/COLOR]
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO, s1 As Object
Dim SQLStr As String
[COLOR=seagreen]'Kaynak = Application.GetOpenFilename("Excel Dosyası (*.xls),*.xls", , "Hedef Dosyayı Seçiniz")[/COLOR]
[COLOR=seagreen]'If Kaynak = False Then Exit Sub[/COLOR]
Kaynak =[COLOR=black] "[/COLOR][URL="file://\\server\wasp.xls"][COLOR=black]\\server\wasp.xls[/COLOR][/URL][COLOR=black] "[/COLOR]
Set s1 = Sheets("hive")
SQLStr = "SELECT  * FROM [hive$a1:d1000]"
Set Baglanti = CreateObject("ADODB.Connection")
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak
        .CursorLocation = adUseClient
        .Mode = adModeReadWrite
        .Open
    End With
    If Err = 0 Then
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************
    If s1.Range("a2").Value <> "" Then
        For i = 2 To s1.[a65536].End(3).Row
            Kayit1.AddNew
                Kayit1(0).Value = s1.Cells(i, "a").Value
                Kayit1(1).Value = s1.Cells(i, "b").Value
                Kayit1(2).Value = s1.Cells(i, "c").Value
                Kayit1(3).Value = s1.Cells(i, "d").Value
            Kayit1.Update
        Next i
    MsgBox "Kayıtlar Başarıyla Aktarıldı.", vbInformation, "Bilgi"
    Else
    MsgBox "Kayıt Bulunamadı.", vbInformation, "Bilgi"
    End If
Else
Son:
    MsgBox "Bağlantı Hatası.Kontrol Ediniz", vbInformation, "Bilgi"
End If
[COLOR=blue]Set[/COLOR] s1 = [COLOR=blue]Nothing[/COLOR]
If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
[COLOR=blue]Set[/COLOR] Kayit1 = [COLOR=blue]Nothing[/COLOR]
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
[COLOR=blue]Set[/COLOR] Baglanti = [COLOR=blue]Nothing[/COLOR]
End Sub

 

[fmt1976]

güzel ama

Hocam teşekürler güzel olmuş ama bir sorun var.Ben eski verileri silip üzerine yazmasını istiyorum yanlız bu örnek üstüne değil en son habgi satırda kalmış ise oraya yazıyor.

 

[Recep İpek]

Şimdilik aklıma gelen çözümü dosyaya uygulamadım.

Biraz üstünde çalışmak gerekiyor..