Hücre içindeki belirli değeri yan hücreye yazdırma

[ayhanycelik]

Merhabalar,

A sütünunda aşağıdaki şekilde yaklaşık 200 satır verim var ve ben bu hücrelerdeki verilerin içinden TR-4.. ve DE-4.. başlayan verinin 4'lü değerini yan satıra almak isityorum. değerlerin bazıları sonda bazıları ortada ve bazıları başta olabiliyor dolayısıyla baştan veya sondan değer al yapamıyorum makro ile nasıl bir kod yapılmalı

Türkiye 02.12.2022 TR-40001873	40001873​
Almanya DE-45001874 02.12.2022	45001874​
Türkiye 03.12.2022 TR-40001873	40001873​
TR-40001874 05.12.2022 Türkiye	40001874​

 

[Necdet]

Merhaba,

Altın üyesiniz, neden dosya değil de resim ekliyorsunuz?

 

[ayhanycelik]

merhaba @Necdet bey tüm kullanıcılar da görebilsin istedim hem kodu hem problemimi

 

[Necdet]

Doğru duyorsunuz ama kodlarını denemek isteyenler ayrıca bir kopyalama ve düzeltme işlemleri yapmak zorunda kalıyor.

 

[ayhanycelik]

@Necdet bey dosyayı ekledim teşekkürler

 

[Haluk]

Sub Test()
'   Haluk - 02/12/2022
    Dim NoA As Long, regExp As Object, myStr As String, i As Long
 
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    Range("B1:B" & NoA) = ""
 
    Set regExp = CreateObject("VBScript.RegExp")
 
    regExp.IgnoreCase = True
    regExp.Global = True
    regExp.Pattern = "[A-Z]{2}\-(\d+)"
 
    For i = 1 To NoA
        myStr = Range("A" & i)
        If regExp.Test(myStr) Then
            Range("B" & i) = regExp.Execute(myStr)(0).Submatches(0)
        End If
    Next
 
    Set regExp = Nothing
End Sub

.

 

[dEdE]

Ben böyle anladım

Sub Bul()
ss = Cells(Rows.Count, "A").End(3).Row
For i = 1 To ss
    x = InStr(1, Cells(i, 1), "DE", 0) Or InStr(1, Cells(i, 1), "TR", 0)
    Cells(i, 2) = Mid(Cells(i, 1), x + 3, 8)
Next
End Sub

* Üstad Haluk hocam cevaplamış bile.

 

[ayhanycelik]

@Haluk Bey çok teşekkür ederim eğer bir hücrede aradağım veriden bir kaç adet varsa (TR-4..) onlarıda almak istesem nasıl yapmalıyım

TR-40001877 5.12.2022 Türkiye

TR-40001874 5.12.2022 TR-40001574 Türkiye

TR-40001278 5.12.2022 Türkiye

TR-40001170 5.12.2022 TR-40001575 Türkiye

 

[Haluk]

Sub Test2()
'   Haluk - 02/12/2022
    Dim NoA As Long, regExp As Object, i As Long, RetVal As Object, r As Integer, c As Integer
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
   
    Set regExp = CreateObject("VBScript.RegExp")
   
    regExp.IgnoreCase = True
    regExp.Global = True
    regExp.Pattern = "[A-Z]{2}\-(\d+)"
   
    For i = 1 To NoA
        If regExp.Test(Range("A" & i).Text) Then
            r = r + 1
            c = 1
            For Each RetVal In regExp.Execute(Range("A" & i).Text)
                c = c + 1
                Cells(r, c) = RetVal.Submatches(0)
            Next
        End If
    Next
   
    Set regExp = Nothing
End Sub

.

 

[ayhanycelik]

@Haluk bey ilk kodu silerek sadece son kodu kullanmalıyım değil mi, ancak yeni kod sadece hücredeli tek TR-.. değerini alıyor iki ya da daha fazlaysa onu almıyor

 

[Haluk]

Verdiğiniz örneklere göre kod çalışıyor, sıkıntı yok.

Ekli dosyayı deneyin....

.

 

[Haluk]

Dosyayı denediniz mi?


.

 

[mehmet230023]

Merhabalar Alternatif olarak Sağa ve aşağı sürükleyerek deneyiniz.

=EĞERHATA(PARÇAAL($A1;BUL("#";YERİNEKOY($A1;"-";"#";SÜTUN(A1)))+1;8);"")

 

[ayhanycelik]

@Haluk bey çok teşekkür ederim, makro değerleri bir yan hücreye alıyor ve bir hücrede birden fazla değer varsa yan yana gösteriyor ancak ben bu değerleri B sütunundan itibaren alt alt alta getirmek isiyorum yani tek sütünda tüm ayrılan değerleri görmem mümkünmüdür

 

[Haluk]

Umarım artık başka bir revizyon istemezsiniz.....

.

 

[ayhanycelik]

çok teşekkür ederim @Haluk bey süpersiniz

 

[ayhanycelik]

@Haluk bey destekleriniz için çok teşekkür ederim; excelin son halinde TR- ve DE ön ekinden ayrılmış listeye ulaşabiliyrum. yeni bir ihtayaç olarak TR-4,DE-4 gibi ön ekleri ile C sütununda benzer şeklide sıralamak için kodu nasıl revizesi gerekir,
(TR-40001874 )

 

[Haluk]

Eskisinin yerine, aşağıdakini kullanın;

    regExp.Pattern = "([A-Z]{2}\-\d+)"

Ayrıca, aşağıdaki linkten de test edebilirsiniz;

Rubular

Ruby-based regular expression editor/tester

rubular.com

.

 

[ayhanycelik]

@Haluk Bey çok teşekkür ederim