İki Sayfa Arasında Belli bir Metin Bilgisi Getirme

[cimcoz]

Merhabalar,

Dosyamda DURUM ve OKUL adlı iki sayfa bulunuyor.
OKUL sayfasında ilk kolondaki NO sütunundaki sayı, DURUM sayfasında Şehir No başlıklı B-K kolonlarına yazıldığında, OKUL sayfasındaki B sütunundan ":" (iki nokta üst üste) olan kısma kadar ki yazılmış olan şehir adını DURUM sayfasında ŞEHİRLER başlığında L kolonundan itibaren getirmesi gerekiyor. (XXXX : Açıklama olan yerden XXXX gelecek sadece)
Gerekli fonksiyon/makro konusunda yardımınızı rica ederim. (DURUM sayfasında, aynı satırda aynı NO birden fazla kullanılabilir.)

Örnek dosya ektedir.

Saygılarımla,

 

[Ziynettin]

Merhaba.

Kodu test ediniz.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("DURUM")
Set s2 = Sheets("OKUL")

son = s2.Range("A" & Rows.Count).End(3).Row
a = s2.Range("A1:B" & son).Value
Set dc = CreateObject("scripting.dictionary")

    For i = 2 To UBound(a)
        dc(a(i, 1)) = Split(a(i, 2), ":")(0)
    Next i

son = 0
son = s1.Range("A" & Rows.Count).End(3).Row
b = s1.Range("B2:K" & son).Value
ReDim c(1 To UBound(b), 1 To UBound(b, 2))

    For i = 1 To UBound(b)
        For j = 1 To UBound(b, 2)
            krt = b(i, j)
            If dc.exists(krt) Then
                c(i, j) = dc(krt)
            End If
        Next j
    Next i

s1.[L2].Resize(UBound(b), UBound(b, 2)) = c

MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Korhan Ayhan]

Fonksiyonla alternatif çözüm.

L2;

=EĞERHATA(YERİNEKOY(DÜŞEYARA(B2;OKUL!$A:$B;2;0);" : Açıklama";"");"")

 

[cimcoz]

Fonksiyonla alternatif çözüm.

L2;

=EĞERHATA(YERİNEKOY(DÜŞEYARA(B2;OKUL!$A:$B;2;0);" : Açıklama";"");"")

Teşekkür ederim. Yalnız " : Açıklama" olan yerde farklı metinler var ben örnek olması açısından yazmıştım. ":" ye kadar olan kelimeyi almam gerekiyor. hariç)

 

[cimcoz]

Merhaba.

Kodu test ediniz.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("DURUM")
Set s2 = Sheets("OKUL")

son = s2.Range("A" & Rows.Count).End(3).Row
a = s2.Range("A1:B" & son).Value
Set dc = CreateObject("scripting.dictionary")

    For i = 2 To UBound(a)
        dc(a(i, 1)) = Split(a(i, 2), ":")(0)
    Next i

son = 0
son = s1.Range("A" & Rows.Count).End(3).Row
b = s1.Range("B2:K" & son).Value
ReDim c(1 To UBound(b), 1 To UBound(b, 2))

    For i = 1 To UBound(b)
        For j = 1 To UBound(b, 2)
            krt = b(i, j)
            If dc.exists(krt) Then
                c(i, j) = dc(krt)
            End If
        Next j
    Next i

s1.[L2].Resize(UBound(b), UBound(b, 2)) = c

MsgBox "İşlem tamam.", vbInformation
End Sub

Teşekkürler. Yalnız makro çalıştırıldığında ekrana sadece İşlem Tamam mesajı çıkıyor. İlgili hücreler güncellenmiyor.

 

[Ali]

L2 hücresine

=EĞERHATA(SOLDAN(DÜŞEYARA(B2;OKUL!$A$2:$B$100;2;0);MBUL(":";DÜŞEYARA(B2;OKUL!$A$2:$B$100;2;0))-1);"")

yazıp sağa ve aşağı doğru çekerek Şehirler tablosunu doldurunuz.

 

[cimcoz]

L2 hücresine

=EĞERHATA(SOLDAN(DÜŞEYARA(B2;OKUL!$A$2:$B$100;2;0);MBUL(":";DÜŞEYARA(B2;OKUL!$A$2:$B$100;2;0))-1);"")

yazıp sağa ve aşağı doğru çekerek Şehirler tablosunu doldurunuz.

Sayın Ali,

Öncelikle ilginize teşekkür ederim. Yalnız formül veri getirmiyor. Yolladığım dosya üzerinde yapma şansınız olursa çok sevinirim.

 

[Ali]

Dosya ektedir.

 

[Korhan Ayhan]

Teşekkür ederim. Yalnız " : Açıklama" olan yerde farklı metinler var ben örnek olması açısından yazmıştım. ":" ye kadar olan kelimeyi almam gerekiyor. hariç)

En önemli detayı en sona yazınca tüm emekler boşa gidiyor.

 

[cimcoz]

Dosya ektedir.

Çok teşekkür ederim. Ellerinize sağlık. Sorunsuz çalıştı.

 

[cimcoz]

En önemli detayı en sona yazınca tüm emekler boşa gidiyor.

Estağfurullah Korhan Bey, yazdığınız formülü de farklı bir yapı için kullanacağım. Açıklama yazan yerde sabit bir metin olan başka bir dosyam var. Yani emeğiniz boşa gitmedi hatta aksine başka bir dosyama yardımcı oldu. Saygılarımla,