Excelde açıklama içindeki veriyi hücreye yazdırmak

[sırakaya]

Merhabalar
Örnek tabloya benze yaklaşık 2000 satırlık bir dosyam var ve ödeme tarihlerini açıklama içine eklemişler, ben bunu açıklama içinden yan hücreye yazdırmak istiyorum. Şimdiden yardımlarınız için teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Bütün açıklamalar bu şekilde mi? İçinde tarih olmayan başka açıklamalar da var mı?
Eğer hepsi bu şekildeyse aşağıdaki kodu kullanabilirsiniz.

Sub kod()
s = Cells(Rows.Count, "B").End(3).Row
For Each hcr In Range("B2:B" & s).SpecialCells(xlCellTypeComments)
    hcr.Offset(0, 1).Value = CDate(Split(hcr.Comment.Text, vbLf)(1))
Next
End Sub

 

[Orion1]

Bir ktf yaptım.
C2 ye yazın aşağı doğru çoğaltın.
Örnek: =tutar(B2)

Function tutar(ByRef hucre As Range)
aciklama = hucre.Comment.Text
tutar = aciklama
End Function

 

[sırakaya]

Merhaba,
Bütün açıklamalar bu şekilde mi? İçinde tarih olmayan başka açıklamalar da var mı?
Eğer hepsi bu şekildeyse aşağıdaki kodu kullanabilirsiniz.

Sub kod()
s = Cells(Rows.Count, "B").End(3).Row
For Each hcr In Range("B2:B" & s).SpecialCells(xlCellTypeComments)
    hcr.Offset(0, 1).Value = CDate(Split(hcr.Comment.Text, vbLf)(1))
Next
End Sub

Ömer bey içinde tarihten sonra gelen bazı açıklamalarda mevcut

 

[ÖmerBey]

Kodu denediniz mi?
Eğer hata verdiyse örnek dosyanızı farklı açıklamaları da içerecek şekilde günceller misiniz?

 

[Orion1]

Dosya ektedir.

 

[sırakaya]

Dosya ektedir.

Sevgili Orion yardımınız için teşekkür ederim, ben örneklendirmeyi eksik yaptım o yüzden de sanırım sıkıntı yaşıyorum. Gönderdiğiniz ekte uygulayınca çalışıyor fakat ana tabloda problem yaşıyorum. Daha kapsamlı eki gönderiyorum.

 

[sırakaya]

Kodu denediniz mi?
Eğer hata verdiyse örnek dosyanızı farklı açıklamaları da içerecek şekilde günceller misiniz?

Ömer bey teşekkür ediyorum uğraştırıyorum sizleri ,yüklemiş olduğum ekte sıkıntı yok çalışıyor fakat ana tablomda çalışmadı.

 

[ÖmerBey]

Aşağıdaki kodu deneyiniz...

Sub kod()
s = Cells(Rows.Count, "B").End(3).Row
For Each hcr In Range("B2:B" & s).SpecialCells(xlCellTypeComments)
    hcr.Offset(0, 1).Value = Ayikla(hcr.Comment.Text)
Next
End Sub
Private Function Ayikla(met)
    Dim re, deg
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "[\d]+[/.][\d]+[/.][\d]+"
    re.Global = True

    For Each deg In re.Execute(met)
        If IsDate(deg.Value) Then
            Ayikla = CDate(deg.Value)
            Exit For
        End If
    Next
    Set re = Nothing
End Function

 

[sırakaya]

Ben örneklendirme de eksik kaldım sizleri de uğraştırdım hakkınızı helal edin, teslim aldığım tablo bu şekilde ve ben en son senedin kapandığı tarihlere göre bir liste oluşturacağım, açıklamalarda bu tarihler karışık yazdığı içinde icmale dökemedim. açıklamaları hücrelere ekleyerek oradan son ödenen tarihleri belirleyip bir özet çıkarma çabasındayım.

 

[Orion1]

Benim yazdığım fonksiyonu dosyanızda vbe de standart bir modüle yazarsanız,çalışacaktır.

 

[sırakaya]

Benim yazdığım fonksiyonu dosyanızda vbe de standart bir modüle yazarsanız,çalışacaktır.

Sevgili orion oldu, teşekkür ederim yardımınız ve zaman ayırdığınız için.

 

[sırakaya]

Aşağıdaki kodu deneyiniz...

Sub kod()
s = Cells(Rows.Count, "B").End(3).Row
For Each hcr In Range("B2:B" & s).SpecialCells(xlCellTypeComments)
    hcr.Offset(0, 1).Value = Ayikla(hcr.Comment.Text)
Next
End Sub
Private Function Ayikla(met)
    Dim re, deg
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "[\d]+[/.][\d]+[/.][\d]+"
    re.Global = True

    For Each deg In re.Execute(met)
        If IsDate(deg.Value) Then
            Ayikla = CDate(deg.Value)
            Exit For
        End If
    Next
    Set re = Nothing
End Function

Ömer Bey yardımınız için çok teşekkür ederim, tam istediğim gibi vermiş olduğunuz kod işime yaradı. Zaman ayırdığınız için teşekkürler.