Değerli Forum Kullanıcıları iyi akşamlar.
Bu saatte herkese bol bol kolay gelsin.
Aşağıdaki kodlar epeyce bir karıştı. Yapmak istediğim çift tıklama olayı ile tıklanan hücrenin bulunduğu satırları, tıklanan hücrenin adı ile anılmakta olan sayfalara, bu satırları birbirini takip eden sıra ile yukarıdan aşağıya aktarmak. Buraya kadar sorun yok. Sorun aktarmanın yapılacağı sayfa sadece 1. sayfa olmaması. Aktaran sayfa 3 adet aktarılan ise bir adet mesela sayfa.4 gibi. Ancak diğer sayfalardanda aktarma yapılması durumunda bir önce işlenmiş olan verinin hemen altından, diğerini silmeden bu işin gerçekleşmesi amaç. Aşağıda bunu yapmaya çalıştığım bir alıntı yazılım var ama bu amaca göre oluştutrurken hayli karıştı. Bir bakabilir misiniz nasıl devam ettirmek gerekecek.
Saygılarımla.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If ActiveCell.Row = 1 Then Exit Sub
Kolon = ActiveCell.Column
Sayfa_Adi = Cells(ActiveCell.Row, Kolon).Value 'Çift Tıklanan Satırın A sütununun Adını Sayfa_Adi değişkenine aktarılıyor
If Sayfa_Adi = "" Then Exit Sub 'Boş Satırda çift tıklandığında işlemi dikkate alma
Var = 0 ' Var değişkenine Sıfır Atanıyor
Adet = 0 'Adet değişkenine Sıfır değeri atanıyor
For i = 1 To Worksheets.Count 'Daha önce sayfa varsa onun kontrolünün döngüsü
If Sheets(i).Name = Sayfa_Adi Then 'eşitliği kontrol ediliyor
Var = 1 'Eşitse Var değişkenine 1 Atanıyor
Exit For 'Döngüden çıkış sağlanıyor
End If 'Karşılaştırmanın Sonu
Next 'Döngünün Sonu
If Var = 0 Then 'İlgili Sayfa yoksa, o adla sayfa oluşturuluyor
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sayfa_Adi
End If
'Sayfa1 seçiliyor
'aktarılacak sayfayı boşaltılıyor
'J değişkenine 1 aktarılıyor, bu aktarılacak sayfada 1. satırın başlık olduğunu düşünerek 1 atanmıştır
Next
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "Sayfa_adi" Then
sat = Cells(65536, "A").End(xlUp).Row + 1
For j = 1 To Sheets(i).Cells(65536, "A").End(xlUp).Row
'aktarılacak sayfaya başlığın aktarılması
'Aktarılacak satırların seçimi için döngü oluşturuluyor
'i değişkeni ile belirtilen sütunun ve kolon ile belirtilen Hücrenin Sayfa_adi değişkenine eşitse karşılaştırılması yapılıyor
'Kaç satır aktardığımızı anlamak için tutulan değişken
adr1 = Range(Cells(j, "A"), Cells(i, "A")).Address 'Sütunlar Teker teker aktarılıyor
adr2 = Range(Cells(sat, "B"), Cells(i, "B")).Address
Range(adr2).Value = Sheets(i).Range(adr1).Value
sat = sat + 1
End If 'Karşılaştırmanın Sonu
Next 'Döngünün Sonu
If Adet > 0 Then 'Adet Değişkeni Sıfırdan farklı ise, aktarım sağlanmıştır, bunun mesajı veriliyor
MsgBox Sayfa_Adi & " Sayfasına " & Adet & " Adet Kayıt Aktarılmıştır"
End If
End Sub
Bu saatte herkese bol bol kolay gelsin.
Aşağıdaki kodlar epeyce bir karıştı. Yapmak istediğim çift tıklama olayı ile tıklanan hücrenin bulunduğu satırları, tıklanan hücrenin adı ile anılmakta olan sayfalara, bu satırları birbirini takip eden sıra ile yukarıdan aşağıya aktarmak. Buraya kadar sorun yok. Sorun aktarmanın yapılacağı sayfa sadece 1. sayfa olmaması. Aktaran sayfa 3 adet aktarılan ise bir adet mesela sayfa.4 gibi. Ancak diğer sayfalardanda aktarma yapılması durumunda bir önce işlenmiş olan verinin hemen altından, diğerini silmeden bu işin gerçekleşmesi amaç. Aşağıda bunu yapmaya çalıştığım bir alıntı yazılım var ama bu amaca göre oluştutrurken hayli karıştı. Bir bakabilir misiniz nasıl devam ettirmek gerekecek.
Saygılarımla.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If ActiveCell.Row = 1 Then Exit Sub
Kolon = ActiveCell.Column
Sayfa_Adi = Cells(ActiveCell.Row, Kolon).Value 'Çift Tıklanan Satırın A sütununun Adını Sayfa_Adi değişkenine aktarılıyor
If Sayfa_Adi = "" Then Exit Sub 'Boş Satırda çift tıklandığında işlemi dikkate alma
Var = 0 ' Var değişkenine Sıfır Atanıyor
Adet = 0 'Adet değişkenine Sıfır değeri atanıyor
For i = 1 To Worksheets.Count 'Daha önce sayfa varsa onun kontrolünün döngüsü
If Sheets(i).Name = Sayfa_Adi Then 'eşitliği kontrol ediliyor
Var = 1 'Eşitse Var değişkenine 1 Atanıyor
Exit For 'Döngüden çıkış sağlanıyor
End If 'Karşılaştırmanın Sonu
Next 'Döngünün Sonu
If Var = 0 Then 'İlgili Sayfa yoksa, o adla sayfa oluşturuluyor
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sayfa_Adi
End If
'Sayfa1 seçiliyor
'aktarılacak sayfayı boşaltılıyor
'J değişkenine 1 aktarılıyor, bu aktarılacak sayfada 1. satırın başlık olduğunu düşünerek 1 atanmıştır
Next
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "Sayfa_adi" Then
sat = Cells(65536, "A").End(xlUp).Row + 1
For j = 1 To Sheets(i).Cells(65536, "A").End(xlUp).Row
'aktarılacak sayfaya başlığın aktarılması
'Aktarılacak satırların seçimi için döngü oluşturuluyor
'i değişkeni ile belirtilen sütunun ve kolon ile belirtilen Hücrenin Sayfa_adi değişkenine eşitse karşılaştırılması yapılıyor
'Kaç satır aktardığımızı anlamak için tutulan değişken
adr1 = Range(Cells(j, "A"), Cells(i, "A")).Address 'Sütunlar Teker teker aktarılıyor
adr2 = Range(Cells(sat, "B"), Cells(i, "B")).Address
Range(adr2).Value = Sheets(i).Range(adr1).Value
sat = sat + 1
End If 'Karşılaştırmanın Sonu
Next 'Döngünün Sonu
If Adet > 0 Then 'Adet Değişkeni Sıfırdan farklı ise, aktarım sağlanmıştır, bunun mesajı veriliyor
MsgBox Sayfa_Adi & " Sayfasına " & Adet & " Adet Kayıt Aktarılmıştır"
End If
End Sub
