kitaptan kitaba aktarma

[h.temel]

Merhaba, ekteki dosyada 2 adet kitap var, benim istediğim 1 isimli kitaptan 2 isimli kitaba istenilen hücreleri aktarmak. Bunu yaparken 2 isimli kitabın açık olup-olmamasının benim için bir önemi yok. Ama makro kendisi açıp kayıt edip kapatırsa güzel olur.
Teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.
Excel4 makro kullandım.

Sub aktar_59()
Dim sat As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(sat, "A").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[1.xls]Sayfa1'!R1C1")
Cells(sat, "B").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[1.xls]Sayfa1'!R2C2")
Cells(sat, "C").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[1.xls]Sayfa1'!R3C3")
MsgBox "Veri Alındı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[h.temel]

İlginiz için teşekkür ederim.

Ben aslında tam tersini (yani 1 nolu dosyadan 2 nolu dosyaya aktarmak) istiyorum. Çünkü 1 nolu dosyanın adı sürekli değişecek, 2 nolu dosya ise sabit olacak.

 

[Orion1]

İlginiz için teşekkür ederim.

Ben aslında tam tersini (yani 1 nolu dosyadan 2 nolu dosyaya aktarmak) istiyorum. Çünkü 1 nolu dosyanın adı sürekli değişecek, 2 nolu dosya ise sabit olacak.

Dosyanız ektedir.

Sub veri_gonder59()
Dim sat As Long
If Workbooks.Open(ThisWorkbook.Path & "\2.xls").ReadOnly = True Then
    Workbooks("2.xls").Close
End If
sat = Workbooks("2.xls").Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1

Workbooks("2.xls").Sheets("Sayfa1").Range("A" & sat).Value = _
ThisWorkbook.Sheets("Sayfa1").Range("A1").Value

Workbooks("2.xls").Sheets("Sayfa1").Range("B" & sat).Value = _
ThisWorkbook.Sheets("Sayfa1").Range("B2").Value

Workbooks("2.xls").Sheets("Sayfa1").Range("C" & sat).Value = _
ThisWorkbook.Sheets("Sayfa1").Range("C3").Value

Workbooks("2.xls").Close True

MsgBox "Veriler Aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[h.temel]

Tam istediğim gibi oldu, yardımınız için çok teşekkür ederim.

 

[h.temel]

Merhaba,

Benim aynı dosyalarda yapmak istediğim bir işlem daha var.

Aynı klasör içerisinde farklı isimlerde 1.000 adet kadar excel kitabı var. Bu 1.000 kadar dosyanın hepsinden sabit aynı hücreleri (ekte belirttim) alarak bir tek kitapta, arşiv listesi gibi birşey yapmak istiyorum. Hepsinden tek bir komut ile bunları almak mümkünmüdür, yada en kolay yolu nedir?

Teşekkür ederim.

 

[Orion1]

Merhaba,

Benim aynı dosyalarda yapmak istediğim bir işlem daha var.

Aynı klasör içerisinde farklı isimlerde 1.000 adet kadar excel kitabı var. Bu 1.000 kadar dosyanın hepsinden sabit aynı hücreleri (ekte belirttim) alarak bir tek kitapta, arşiv listesi gibi birşey yapmak istiyorum. Hepsinden tek bir komut ile bunları almak mümkünmüdür, yada en kolay yolu nedir?

Teşekkür ederim.

Merhaba.
hangi dosya 100 dosyadan belli hücrelerden veriler alınacak bir dosyaya aktartılacak.
Aktarılacak dosya verdiğiniz dosyalardan hangisi olacak
ve aktarılacak dosyadan hangi hücreler aktarılacak.ve hangi sayfadan aktarılacak.sayfa adlarının hepsi ayni olması lazım?

 

[h.temel]

Evren bey ilginiz için teşekkür ederim.

klişe iş emri 1-2-3 isimli kitaplardan, KLİŞE isimli kitaba aktarılacak.

klişe iş emri 1-2-3 isimli kitaplarda önceki yazdığınız makrodan var. Aktarılacak hücreler orada yazıyor ama siz sadece F8 hücresini, KLİŞE isimli kitabın A sütununda en alta getirin geri kalanları ben hallederim.

aktarılacak olan dosyaların hepsinde tek sayfa var ve "Sayfa1" isimli.

 

[Orion1]

Evren bey ilginiz için teşekkür ederim.

klişe iş emri 1-2-3 isimli kitaplardan, KLİŞE isimli kitaba aktarılacak.

klişe iş emri 1-2-3 isimli kitaplarda önceki yazdığınız makrodan var. Aktarılacak hücreler orada yazıyor ama siz sadece F8 hücresini, KLİŞE isimli kitabın A sütununda en alta getirin geri kalanları ben hallederim.

aktarılacak olan dosyaların hepsinde tek sayfa var ve "Sayfa1" isimli.

Çalıştırmak için KLİŞE adlı dosyadaki butona tıklayınız.
Dosyanız ektedir.

Sub aktar_59()
Dim sat As Long, dosya As String, i As Long
dosya = Dir(ThisWorkbook.Path & "\*.xls")
Do While dosya <> ""
    If dosya <> ThisWorkbook.Name Then
        sat = Cells(Rows.Count, "E").End(xlUp).Row + 1
        Cells(sat, "E").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "]Sayfa1'!R8C6")
    End If
    dosya = Dir
Loop
MsgBox "Veri Alındı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[h.temel]

Evren Bey yardımcı olduğunuz için teşekkür ederim.

Gönderdiğiniz dosyada sadece 1 sütunu getiriyordu, biraz karışıtırıp diğerlerinide bulup hallettim. İyikide eksik göndermişsiniz birşeyler öğrenmiş oldum, ayrıca teşekkür ederim.