sectiğim dosyaya veri aktarma

[onderkaptan]

arkadaşlar;
vba dosya adı sectirerek o dosyadaki isteğim datayı x adı ile kayıtlı dosyada istediğim yere yazdırıyorum. Fakat bu olayın tam tersını yapmamda gerekiyor. x dosyasının a1 deki değerini en başta açtığım dosyada g5:h5 hücresinede yazdırıp dosyayı da buraya yazdıgı metin olarak kayıt etmesini istiyorum. VBA de bunu yapabilirmiyim? Çok uğraştım fakat seçtiğim dosyanın sheeti secip datayı x dosyasından bir türlü atmayı beceremedim. Bu konuda yardımcı olabilirseniz çok sevinirim. aşağıda kodumun örneği bulunmaktadır. ben seçtiğim dosyanın sectiğim sheetine x dosyasından veri alabilmesi için söyle bir kod yazdım fakar program hata veriyor. 'Sheets("[" & SAYFA & "$" & "g5:H5" & "]").Activate = Workbooks("ARIZA ONARIM FORMLARI.xls").Sheets("ARIZA ONARIM FORMLARI").Range("a" & sat)







Function DosyaAdiGetir()
On Error Resume Next
Dim i As Integer
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
i = Application.WorksheetFunction.Find("\", StrReverse(.SelectedItems(1)))
If i = 0 Then Exit Function
DosyaAdiGetir = Left(.SelectedItems(1), Len(.SelectedItems(1)) - i + 1) & Right(.SelectedItems(1), i - 1)
End With
End Function

Sub aktar()

Set baglanti = CreateObject("ADODB.Connection")

yol = "DRIVER={Microsoft Excel Driver (*.xls)};" & "DBQ=" & DosyaAdiGetir()
baglanti.Open yol
SAYFA = InputBox("SAYFAADI")

'model marka
Set rs = baglanti.Execute("[" & SAYFA & "$" & "D9:E9" & "]")
sat = Workbooks("x.xls").Sheets("x").Range("c5000").End(3).Row + 1
Range("c" & sat) = rs.Fields(0).Name
Workbooks("x.xls").Sheets("x").Range("b" & sat).Formula = Date

 

[Korhan Ayhan]

Selamlar,

Örnek dosya ekleyerek ne yapmak istediğiniz açıklarsanız sonuca gitmek daha kolay olacaktır.

 

[onderkaptan]

Korhan Bey;

eke örnek dosya ekledım. yardımcı olabılırsenız cok sevınırım. Çok ugrastım fakat bunu başaramadım.veri excelini bir form olarak düşünün ismi ve içindeki bilgiler sürekli değişiyor. data excelide bunları kayıt altına alıyor. Şİmdiden çok teşekür ederim.
İyi çalışmalar

 

[onderkaptan]

yardımcı olabilecek kimse yokmu??
Böyle birsey yapmak mumkunmudur??

 

[onderkaptan]

arkadaslar
bu konuda bilgi sahibi olan varmı ??

 

[Korhan Ayhan]

Selamlar,

ADO konusunda çok bilgi sahibi değilim. Fakat dosyayı açarak çözüm isterseniz yardımcı olmaya çalışırım.

 

[onderkaptan]

merhaba korhan bey;
dosyayı acarım fakat ismi belirlimi olması gerekıyor yoksa değişkenmi?? benım dosya isimlerim sürekli değişiyor. save dışında açılan dosyaya veri yazdırma hakkında bir bilginiz varmı ?
iyi günler

 

[Korhan Ayhan]

Selamlar,

Dosyalarınızın isminin değişmesi problem değil. Sizin kullandığınız dosya seçme kodu kullanılarak farklı çözümler üretilebilir. Dosyanın açılması sizin için problem yaratmıyorsa bu şekilde çözüm üretebiliriz.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. İsteğinize göre geliştirebiliriz.

Option Explicit
 
Sub AKTAR()
    Dim Dosya As Variant, Masaüstü As String
    Dim Data_Dosyası As Workbook, Veri_Dosyası As Workbook
    Dim Sayfa_Adı As String, Satır As Long, Yeni_Dosya As String
 
    Set Data_Dosyası = ThisWorkbook
 
    Masaüstü = CreateObject("WScript.Shell").SpecialFolders("Desktop")
 
    Dosya = Application.GetOpenFilename("Excel Dosyaları (*.xls), *.xls")
 
    If Dosya <> False Then
 
    Application.ScreenUpdating = False
        Set Veri_Dosyası = Workbooks.Open(Dosya, False, False)
    Application.ScreenUpdating = True
 
    Sayfa_Adı = InputBox("Lütfen sayfa adı giriniz.", , "X")
    If Sayfa_Adı = "" Then Sayfa_Adı = "X"
 
    Data_Dosyası.Activate
 
    Satır = Sheets("A").Range("B65536").End(3).Row + 1
    With Sheets("A")
         Satır = .Range("B65536").End(3).Row + 1
        .Range("B" & Satır) = Veri_Dosyası.Sheets(Sayfa_Adı).Range("B2")
        .Range("C" & Satır) = Date
        .Range("D" & Satır) = Veri_Dosyası.Sheets(Sayfa_Adı).Range("B3")
         Veri_Dosyası.Sheets(Sayfa_Adı).Range("B1") = .Range("A" & Satır)
         Yeni_Dosya = .Range("E" & Satır) & ".xls"
    End With
 
    Application.DisplayAlerts = False
        Workbooks(Veri_Dosyası.Name).SaveAs Filename:=Masaüstü & "\" & Yeni_Dosya, FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
 
    Windows(Veri_Dosyası.Name).Close
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
 
    Else
 
    MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
    End If
 
    Set Data_Dosyası = Nothing
    Set Veri_Dosyası = Nothing
End Sub

 

[onderkaptan]

Korhan Bey;
İstediğim şey tam olarak buydu çok teşekür ederim ben bunu genişletip asıl dosyama uygulayacağım. bu kod benım cok ısıme yarayacak. Tek sorun dosyayı masa üstüne kayıt diyor fakat o dosyayı açamıyorum. açmak istediğimde excel açılıyor fakat sayfa gorunmuyor ana excel programı açılıyor diyim. Bu problemi nasıl çözebilirim?

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[onderkaptan]

çok tesekur ederim korhan bey yardımlarınız için. herseyi ile tam istediğim gibi oldu.
teşekurler iyi çalışmalar