Belirli Bir Hücredeki Değişen Değeri Arama, Kopyalama ve Yapıştırma

[Faruk Samet]

Merhaba forum sakinleri,

Şimdiye kadar arama yaparak bir çok şey öğrendim sizin sayenizde ama şu anda arayarak bulamadığım bir çalışma ile karşılaştım.

Ekte örnek dosyada kısaca görsel olarak da anlattım ama buradan da ne yapmak istediğimi biraz uzunca ifade edeyim.

Mevcut olan 20 farklı sınıf listesini seçilen sınıfa göre en kısa yol ile 6 tane boş sınıf listesi tablosuna yapıştırmam gerekiyor. Belirli bir hücreye girilen sınıf adına göre belirli bir satırda bulunan sınıf isimlerini arayacak aynı olanı bulacak ve altındaki sınıf listesini bu 6 boş şablondan istenilene yapıştıracak. Ben macro düşündüm ama sınıf isimleri belli olduğundan formül ile

eğer D6="SINIF1" ise copy D46 E69 aralığı
eğer D6="SINIF2" ise copy F46 G69 aralığı
...
eğer D6="Sınıf20" ise copy X46 y46 aralığı

Formül ile de yapılabilir gibi geliyor. Bu formülün 6 farklı versiyonu ile yapılabilir mi? Bu mu daha kolay olur yoksa o sınıf adını arama yapıp aktif olan hücrenin 30 altını ve bir yan sutununu kopyalayarak ve yapıştırarak mı olur bilemedim. İkisi de işimi görecek gibi ama bu konuda sizin yardımınıza ihtiyacım var.

6 tane aktif sınıf listesinden birçok bölüme bağlantı yaptığım için bu 6 sınıfın da değer olarak kalması ve formül olmaması da gerekiyor.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

3. satırdaki grup numaralarını aynı başlıkların üstüne gelecek şekilde yazarsanız kodu sıkıntısız kullanabilirsiniz. (Mesela 6 numaralı grup kodu diğerlerinden farklı başlık üstünde konumlanmış durumda)

Sub AKTAR()
    Dim Veri As Range, Bul_Hedef As Range, Bul_Sinif As Range
    
    For Each Veri In Range("B6:B11")
        Set Bul_Hedef = Rows("3:3").Find(Veri, , , xlWhole)
        Set Bul_Sinif = Rows("44:44").Find(Veri.Offset(0, 2), , , xlWhole)
        If Not Bul_Hedef Is Nothing And Not Bul_Sinif Is Nothing Then
            Range(Cells(Bul_Sinif.Row + 2, Bul_Sinif.Column), Cells(Bul_Sinif.Row + 25, Bul_Sinif.Column + 1)).Copy Bul_Hedef.Offset(4, 0)
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Faruk Samet]

Teşekkür ederim Korhan bey. O gözümden kaçmış. Numaraları doğru yerlerine koydum. Sorunsuz çalışıyor. 25e yakın hocayı büyük sıkıntılardan kurtardınız