Skip to main content

#EvdeKal


Çoklu Sayfa Kopyalama

Çoklu Sayfa Kopyalama

Çözüldü #1
Herkese merhaba,

Benim sorum şu şekilde. Sayfa1 de benim kopyalamak istediğim şablonum mevcut. Bu şablon hedef alınarak Sayfa2 de bulunan değerlere göre topluca yeni sayfalar açmak istiyorum.
Sayfa 2 de A kolonunda sayfalara vermek istediğim ad B kolonunda yeni sayfalarda istediğim hücreye yazılacak değerler, C kolonunda yeni sayfalarda istediğim hücreye yazılacak değer D kolonunda istediğim hücreye yazılacak değerler olacak.

Şimdiden teşekkür ederim.
.rar Örnek.rar (Dosya Boyutu: 7,33 KB | İndirme Sayısı: 4)
Alıntı:Her şey bir fikirle başlar.
Cevapla
#2
Tekrar merhaba,

Visual Basic Code
Public Sub berat()
On Error Resume Next
Dim MyCell As Range, MyRange As Range, deger1 As Range, deger2 As Range, deger3 As Range

Set MyRange = Sheets("Sayfa2").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set deger1 = Sheets("Sayfa2").Range("B2")
Set deger1 = Range(deger1, deger1.End(xlDown))
Set deger2 = Sheets("Sayfa2").Range("C2")
Set deger2 = Range(deger2, deger2.End(xlDown))
Set deger3 = Sheets("Sayfa2").Range("D2")
Set deger3 = Range(deger3, deger3.End(xlDown))

For Each MyCell In MyRange
Sheets("Sayfa1").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value
Sheets(Sheets.Count).Range("b3").Value = deger1.Value
Sheets(Sheets.Count).Range("f6").Value = deger2.Value
Sheets(Sheets.Count).Range("g4").Value = deger3.Value
Next MyCell


End Sub


Bu şekilde bir kod oluşturdum. Güzel olan taraf A kolonuna göre isimlere sahip sayfa açabiliyorum. Ama açtığım sayfalara istediğim hücrelere yazım yaptıramıyorum.
Yardım ederseniz sevinirim.

Alıntı:Her şey bir fikirle başlar.
Son Düzenleme: 10/06/2019, 13:51, Düzenleyen: nightashes.
Cevapla
#3
aşağıdaki gibi düzenleyip dener misiniz?

Visual Basic Code
Public Sub berat()
On Error Resume Next
Dim MyCell As Range, MyRange As Range, deger1 As Range, deger2 As Range, deger3 As Range
Dim intSatir As Integer

Set MyRange = Sheets("Sayfa2").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set deger1 = Sheets("Sayfa2").Range("B2")
Set deger1 = Range(deger1, deger1.End(xlDown))
Set deger2 = Sheets("Sayfa2").Range("C2")
Set deger2 = Range(deger2, deger2.End(xlDown))
Set deger3 = Sheets("Sayfa2").Range("D2")
Set deger3 = Range(deger3, deger3.End(xlDown))

For Each MyCell In MyRange

Sheets("Sayfa1").Copy After:=Sheets(Sheets.Count)

intSatir = MyCell.Row ' <== eklenen
Sheets(Sheets.Count).Name = MyCell.Value
Sheets(MyCell.Value).ClearContents ' <== eklenen
Sheets(MyCell.Value).Range("b3").Value = Sheets("Sayfa2").Range("B" & intSatir).Value ' <== değişen
Sheets(MyCell.Value).Range("f6").Value = Sheets("Sayfa2").Range("C" & intSatir).Value
Sheets(MyCell.Value).Range("g4").Value = Sheets("Sayfa2").Range("D" & intSatir).Value
Next MyCell


End Sub

Cevapla
#4
(10/06/2019 14:48)haliliyas Adlı Kullanıcıdan Alıntı: aşağıdaki gibi düzenleyip dener misiniz?

Visual Basic Code
Public Sub berat()
On Error Resume Next
Dim MyCell As Range, MyRange As Range, deger1 As Range, deger2 As Range, deger3 As Range
Dim intSatir As Integer

Set MyRange = Sheets("Sayfa2").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set deger1 = Sheets("Sayfa2").Range("B2")
Set deger1 = Range(deger1, deger1.End(xlDown))
Set deger2 = Sheets("Sayfa2").Range("C2")
Set deger2 = Range(deger2, deger2.End(xlDown))
Set deger3 = Sheets("Sayfa2").Range("D2")
Set deger3 = Range(deger3, deger3.End(xlDown))

For Each MyCell In MyRange

Sheets("Sayfa1").Copy After:=Sheets(Sheets.Count)

intSatir = MyCell.Row ' <== eklenen
Sheets(Sheets.Count).Name = MyCell.Value
Sheets(MyCell.Value).ClearContents ' <== eklenen
Sheets(MyCell.Value).Range("b3").Value = Sheets("Sayfa2").Range("B" & intSatir).Value ' <== değişen
Sheets(MyCell.Value).Range("f6").Value = Sheets("Sayfa2").Range("C" & intSatir).Value
Sheets(MyCell.Value).Range("g4").Value = Sheets("Sayfa2").Range("D" & intSatir).Value
Next MyCell


End Sub


Çok teşekkür ederim. Aramadığım yer kalmamıştı. İstediğim gibi değerleri çekiyor.
Alıntı:Her şey bir fikirle başlar.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task