Kısmen çoklu sayfa kopyalama.

[Bora K]

Merhabalar;

"Eski Kitap" ın sayfalarındaki verieri birebir (Copy/Paste ile ) "Yeni Kitap"
ın aynı adlı sayfalarına aktarmak istiyorum. Sadece belirttiğim adresteki veriler aktarılacak. (Veri adresleri tüm sayfalarda aynı içerikleri farklı)
adresler şunlar (B8:B15),(C12:C13),(D14: D16),(E11),(F7)

Aktarma Her iki kitapta açık olduğu halde;
Ahmet ten Ahmet e
Mehmet ten Mehmet e
Murat tan Murat a
…....... dan ..........
şeklinde devam edecek.

Yanlız "Yeni kitapta" bu kitapta olmayan "aa" ve "bb" isimli 2 sayfamız var. Bu sayfalara herhangi birşey aktarılmayacak.

Değerli arkadaşlar yardımlarınızı bekliyorum.
Saygılarımla.

 

[Bora K]

Merhabalar arkadaşlar.
Konum günceldir.

 

[asi_kral]

Merhaba
Sanırım sizin böyle bir sorunuza ben yanıt vermiştim. İşinizi görmedi mi_?

 

[Bora K]

Merhaba Kral
Teşekkür ederim. O kod ile işimi hallettim. Bu dosyada sayfa sayıları çok fazla.
Eğer o kodu bu dosyaya göre revize edebilirseniz çok sevinirim.
(Taşınacak hücre adresleri farklı)

ilgili kod:

Option Explicit
Sub veri_aktar()
Dim s1 As Worksheet, S2 As Worksheet, ÇLŞ As String
Application.ScreenUpdating = False
ÇLŞ = ActiveWorkbook.Name
Set s1 = ActiveSheet
Workbooks("hedef.xls").Activate
Set S2 = ActiveSheet
Workbooks(ÇLŞ).Activate
s1.Range("A5:D15").Copy S2.Range("A5")
s1.Range("E4:E17").Copy S2.Range("E4")
s1.Range("F7").Copy S2.Range("F7")
s1.Range("G14").Copy S2.Range("G14")
Workbooks(ÇLŞ).Activate
Application.ScreenUpdating = True
End Sub

 

[asi_kral]

Merhaba
Bu kodu kullanın.

Option Explicit
Sub veri_aktar()
Dim S1 As Worksheet, S2 As Worksheet, ÇLŞ As String
Dim KTP1 As Workbook, KTP2 As Workbook, SYF As Long
Application.ScreenUpdating = False
ÇLŞ = ActiveWorkbook.Name
Set KTP1 = Workbooks(ÇLŞ)
For SYF = 1 To Sheets.Count
Set S1 = KTP1.Sheets(SYF)
Workbooks("Yeni Kitap.xls").Activate
Set KTP2 = ActiveWorkbook
Set S2 = KTP2.Sheets(S1.Name)
Workbooks(ÇLŞ).Activate
S1.Range("B8:B15").Copy S2.Range("B8")
S1.Range("C12:C13").Copy S2.Range("C12")
S1.Range("D14:D16").Copy S2.Range("D14")
S1.Range("E11").Copy S2.Range("E11")
S1.Range("F7").Copy S2.Range("F7")
Next
Application.ScreenUpdating = True
End Sub