Aktif kitaptan başka kitaba veri kopyalama - Sonunda başar

[lovehearts]

Merhaba

Benim istediğim konu bir web sayfasındaki verileri excelle aktar diyerek alıyorum.Bu aldığım verilerin içinden istediklerimi diskimde kayıtlı başka bir kitabın içine eklemek.Her kayıt aldığımda kayıtlı kitabın altına yeni bir satır olarak eklesin

Aktif sayfadaki

B1 - B2 - B7 - D7 - B2 - D8 hücrelerini

kayıtlı kitaba aynı satırda yanyana eklesin

Webden aktardığım için kitap adı sabit olmuyor ama sayfa içindeki verileri sabit bir kitaba aktarıcağı için aktarılacak dosya adı data.xls olarak baz alınabilir.

Hatta data.xls dosyasını açmama gerek kalmadan ekleyebilirsem harika olur.

Çok teşekkürler

 

[Levent Menteşoğlu]

Aşağıdaki linki inceleyin.

http://www.excel.web.tr/viewtopic.php?t=10976

 

[lovehearts]

Yalnız bir sorunum var bunu makro olarak yapamazmıyım? çünkü aktarım yapılacak dosya sabit değil.İnternet sayfasındaki formu excel e gönderip ordan data dosyasına aktarıcam gerekli bilgileri?

 

[Levent Menteşoğlu]

Veri aldığınız dosya ile data dosyanızın bir örneğini eklermisiniz.

 

[lovehearts]

Dosyaları ekte gönderiyorum.

Ã?rnek olarak tc kimlik sorgulamayı verdim.Web sayfasında bir sorgulama yapıp bunu excelle attıktan sonra kitap2 yi kaydetmek zorunda kalmadan makro ile kitap3 ün içine sırayla alta satır ekleme ile istediğim hücreleri kopyalamasını istiyorum.

Sorun şuki her web sayfasında yeni sorgulama yapıp sonucu excelle aktardığımda kitap4 kitap5 kitap6 diye otomatik kitap adı veriyor sabit kalmıyor.Fakat hücrelerin kopyalanacağı kitap diskimde kayıtlı ve sabit.Kayıt yoluda e:\data.xls.

İlginize çok teşekkürler

 

[lovehearts]

Arkadaşlar istediğimin olması mümkün değilmi? kimse bir şey demiyor.Makroyu yeni öğreniyorum ve bir çok makroyu inceledim.Olabileceğine inandım ama olmayacaksa söylerseniz en azından araştırmaktan vazgeçerim.

 

[lovehearts]

Ses yokmu arkadaşlar?

 

[lovehearts]

Aradığımı buldum fakat sorun şu buton şeklinde makroya geçiremiyorum bunu makro olarak çalıştırmayı denedim olmadı

sorun sanırım data dosyasını açması için gerekli yolu tam atayamadımki hata veriyor.

Private Sub CommandButton1_Click()
Dim NewXL As Excel.Application
Dim DataWB As String
Dim NoA As Long
Dim Wb As Workbook

Set NewXL = New Excel.Application
NewXL.Visible = False
DataWB = ThisWorkbook.Path & Application.PathSeparator & "data.xls"
Set Wb = NewXL.Workbooks.Open(DataWB)
NoA = Wb.Sheets(1).Cells(65536, 1).End(xlUp).Row + 1

With Wb.Sheets(1)
.Range("A" & NoA) = Sheets(1).Range("B1")
.Range("B" & NoA) = Sheets(1).Range("B3")
.Range("C" & NoA) = Sheets(1).Range("B7")
.Range("D" & NoA) = Sheets(1).Range("D7")
.Range("E" & NoA) = Sheets(1).Range("B2")
.Range("F" & NoA) = Sheets(1).Range("D8")
End With

NewXL.Workbooks(Dir(DataWB)).Close SaveChanges:=True

Set Wb = Nothing
Set NewXL = Nothing
End Sub

 

[Levent Menteşoğlu]

kodu butona bağlamak için aşağıdaki gibi sub olarak oluşturmalısınız.

Sub kopyala()
Dim NewXL As Excel.Application 
Dim DataWB As String 
Dim NoA As Long 
Dim Wb As Workbook 
 
Set NewXL = New Excel.Application 
NewXL.Visible = False 
DataWB = ThisWorkbook.Path & Application.PathSeparator & "data.xls" 
Set Wb = NewXL.Workbooks.Open(DataWB) 
NoA = Wb.Sheets(1).Cells(65536, 1).End(xlUp).Row + 1 
 
With Wb.Sheets(1) 
.Range("A" & NoA) = Sheets(1).Range("B1") 
.Range("B" & NoA) = Sheets(1).Range("B3") 
.Range("C" & NoA) = Sheets(1).Range("B7") 
.Range("D" & NoA) = Sheets(1).Range("D7") 
.Range("E" & NoA) = Sheets(1).Range("B2") 
.Range("F" & NoA) = Sheets(1).Range("D8") 
End With 
 
NewXL.Workbooks(Dir(DataWB)).Close SaveChanges:=True 
 
Set Wb = Nothing 
Set NewXL = Nothing

 

[lovehearts]

Evet sorunumu çözdüm dün.Nasıl yaptığımı söylemek istiyorum.

Bir excell dosyası yarattım.Onda macro oluşturdum ve aşağıdakileri yazdım

Sub aktar()
Dim NewXL As Excel.Application
Dim DataWB As String
Dim NoA As Long
Dim Wb As Workbook

Set NewXL = New Excel.Application
NewXL.Visible = False
DataWB = ThisWorkbook.Path & Application.PathSeparator & "data.xls"
Set Wb = NewXL.Workbooks.Open(DataWB)
NoA = Wb.Sheets(1).Cells(65536, 1).End(xlUp).Row + 1

With Wb.Sheets(1)
.Range("A" & NoA) = Sheets(1).Range("B1")
.Range("B" & NoA) = Sheets(1).Range("B3")
.Range("C" & NoA) = Sheets(1).Range("B7")
.Range("D" & NoA) = Sheets(1).Range("D7")
.Range("E" & NoA) = Sheets(1).Range("B2")
.Range("F" & NoA) = Sheets(1).Range("D8")
End With

NewXL.Workbooks(Dir(DataWB)).Close SaveChanges:=True

Set Wb = Nothing
Set NewXL = Nothing
End Sub

Daha sonra farklı kaydet dedim ve Microsoft Excel Eklentisi olarak kaydettim.Yarattığım dosyayıda data dosyamla aynı klasöre kaydettim.

Menü çubuğunda özelleştir dedim Makrolar'dan özel makro düğmesini sürükleyip uygun bir konuma yapıştırdım.Bu butona makroyu yarattığım kitapta tıklayarak makro atadım.Gerek varmıydı bilmiyorum ama ayrıca Araçlarda Eklentilere geldim gözat diyerek xla dosyasını seçtim ve işaretleyip pencereyi kapattım.Daha sonra data dosyamı ve makro yarattığım kitabı kapattım.İnternet sayfasına gittim ve sorguladığım form sonucunu excele aktar dedim gelen sayfada yarattığım butona tıkladım.İstediğim şekilde hücreler kapalı kitaba kopyalandı )))))

 

[akd]

selam arkadaşlar,
bu kodları denedim,
sayın lovehard ın kodunu denedim, her seferinde farklı kaydet menüsü çıkıyor,kopyadata diye bir kitap oluşturup, onun içine kaydediyor,
Sayın levendm in kodu
Set Wb = NewXL.Workbooks.Open(DataWB)
bu satırda hata veriyor
ben maaş proğramımdaki gelir vergi matrahlarını data.xls dosyasına yan yana aktarmasını istedim malesef yapamadım ,
ilgilenirseniz çok sevinirim

 

[lovehearts]

Eğer makroyu yazıp kaydettiğiniz kitap data.xls ile aynı klasörde değilse onu yaratmak istiyor.
Bazen bendede aynı hatayı veriyor % 100 başarılı değil, evet bir yerde problem var kitap açıkken kopyalama seçeneğini yapabilseydim çok iyi olurdu

 

[Levent Menteşoğlu]

Kitap zaten bu kodla gizli olarak açılıyor ve veriler kaydedildikten sonra tekrar kaydedilip kapatılıyor. Kodu aşağıdaki gibi değiştirirseniz, aynı klasörde olması gerekmez. Kod içindeki c:\excel yolunu data dosyanızın bulunduğu klasöre göre değiştirin.

[vb:1:e4694e1ff3]Sub aktar()
Dim NewXL As Excel.Application
Dim DataWB As String
Dim NoA As Long
Dim Wb As Workbook

Set NewXL = New Excel.Application
NewXL.Visible = False
DataWB = "c:\excel\data.xls"
Set Wb = NewXL.Workbooks.Open(DataWB)
NoA = Wb.Sheets(1).Cells(65536, 1).End(xlUp).Row + 1

With Wb.Sheets(1)
.Range("A" & NoA) = Sheets(1).Range("B1")
.Range("B" & NoA) = Sheets(1).Range("B3")
.Range("C" & NoA) = Sheets(1).Range("B7")
.Range("D" & NoA) = Sheets(1).Range("D7")
.Range("E" & NoA) = Sheets(1).Range("B2")
.Range("F" & NoA) = Sheets(1).Range("D8")
End With

NewXL.Workbooks(Dir(DataWB)).Close SaveChanges:=True

Set Wb = Nothing
Set NewXL = Nothing
End Sub
[/vb:1:e4694e1ff3]

 

[akd]

Merhaba sayın levendm
Malesef kodu çalıştıramadım,
ben maaş sayfamdaki H4:H15 aralığını data.xls kitabındaki gel_ver sayfasındaki
c2 sutununa aktarmak istedim malesef bayaa ugraştım bir türlü olmadı.
Teşekkürler