Belli harfi içeren kelimelerin yan sütuna taşınması

[farisakboga]

D sütununda 1000'den fazla kelimem var. Bu kelimelerden örneğin içinde "B" harfi olanları E sütununa taşımak istiyorum. Bunu makro ile nasıl yapabilirim?

 

[muygun]

Merhaba;
Altın üyesiniz neden örnek sayfa eklemiyorsunuz?
Ekteki 2 sayfayı inceleyin.
İyi çalışmalar.

 

[bmutlu966]

Alternatif.

Sub bul()
son = [D65000].End(3).Row
Range("E2:R65000").ClearContents

For t = 1 To son
    For s = 1 To Len(Cells(t, "D"))
        x = Mid(Cells(t, "D"), s, 1)
        If x = "B" Then
            Cells(t, "E") = Cells(t, "D")
        End If
    Next
Next

End Sub

 

[Mdemir63]

Selamlar

bir alternatif de bu olsun

Sub bul_Aktar()

Dim sonsat As Long
Dim i As Long, n As Integer
Dim ara As Range

    Range("E2:E1000").ClearContents
    sonsat = Cells(Rows.Count, "D").End(xlUp).Row
    n = 2
        For i = 2 To sonsat
           Set ara = Cells(i, "D").Find("*b*")
        '   Set ara = Range("D" & i).Find("*b*")
            If Not ara Is Nothing Then
                Cells(n, "E") = ara
                n = n + 1
            End If
        Next i
End Sub

 

[farisakboga]

Merhaba;
Altın üyesiniz neden örnek sayfa eklemiyorsunuz?
Ekteki 2 sayfayı inceleyin.
İyi çalışmalar.

Haklısınız, eklemeliydim. Çok teşekkür ederim.

 

[farisakboga]

Selamlar

bir alternatif de bu olsun

Sub bul_Aktar()

Dim sonsat As Long
Dim i As Long, n As Integer
Dim ara As Range

    Range("E2:E1000").ClearContents
    sonsat = Cells(Rows.Count, "D").End(xlUp).Row
    n = 2
        For i = 2 To sonsat
           Set ara = Cells(i, "D").Find("*b*")
        '   Set ara = Range("D" & i).Find("*b*")
            If Not ara Is Nothing Then
                Cells(n, "E") = ara
                n = n + 1
            End If
        Next i
End Sub

Çok teşekür ederim.

 

[farisakboga]

Alternatif.

Sub bul()
son = [D65000].End(3).Row
Range("E2:R65000").ClearContents

For t = 1 To son
    For s = 1 To Len(Cells(t, "D"))
        x = Mid(Cells(t, "D"), s, 1)
        If x = "B" Then
            Cells(t, "E") = Cells(t, "D")
        End If
    Next
Next

End Sub

Çok teşekkür ederim.

 

[Mdemir63]

Rica ederim.
İyi çalışmalar