Kelimeleri ayıklayıp başka sütuna kopyalama ?

[Gorarr]

Selamlar, yapmaya çalıştığım "A "sütunundaki tüm ingilizce kelimelerin tek tek ayıklanıp "B" sütununa kopyalanması.

Yardımlarınız için şimdiden çok çok teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KELİMELER()
    Dim X As Long, Y As Integer, Z As Byte, Satır As Long
    Dim Kelime() As String, Sembol() As Variant
    
    Application.ScreenUpdating = False
    Range("B:C").Clear
    Satır = 2
    Range("B1") = "Kelimeler"
    Range("C1") = "Bulunduğu Satır No"
    Range("B1:C1").Font.Bold = True
    
    Sembol = Array(".", ",", "?", """", "<i>", "</i>")
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        If IsError(Cells(X, 1)) = False Then
            If Cells(X, 1) <> "" Then
                If IsNumeric(Mid(Cells(X, 1), 1, 1)) = False Then
                    Kelime = Split(Cells(X, 1), " ")
                    For Y = 0 To UBound(Kelime())
                        If Kelime(Y) <> "" Then
                            If Kelime(Y) <> "-" Then
                                Cells(Satır, 2) = Kelime(Y)
                                Cells(Satır, 3) = X
                                
                                For Z = 0 To UBound(Sembol())
                                    Cells(Satır, 2) = Replace(Cells(Satır, 2), Sembol(Z), "")
                                Next
                                
                                If Cells(Satır, 2) <> "" Then Satır = Satır + 1
                            End If
                        End If
                    Next
                End If
            End If
        End If
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Gorarr]

Hocam çok teşekkür ederim ellerinize sağlık.

Şimdi aklıma geldi ek olarak ".", ",", "?" gibi noktalama işaretleri hariç tutulabilirmi yada sonradan silinebilirmi. Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

"Sembol" dizisine dilediğiniz kadar ekleme yapabilirsiniz. Ayrıca C sütununa ilgili kelimenin satır numarasınıda yazdırdım. Böylece daha rahat kontrol edebilirsiniz.

 

[Gorarr]

Çok teşekkür ederim. Ellerinize sağlık. saygılar selamalar..

 

[Gorarr]

Korhan hocam saygısızlık gibi olmasın bu "C sütununa ilgili kelimenin satır numarasınıda yazdırma" özelliğini çok şık olmuş ama ben kodları öğrenme açısından kaldırmaya çalıştım fakat kod hep hata verdi. Aceba birde bu özellik olmadan kodları sadeleştirebilirmisiniz. Yardımlarınız için çok çok teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Neden saygısızlık olsun. Ben ihtiyacınız olur düşüncesiyle ekleme yapmıştım. Sorun yok silebiliriz.

Option Explicit
 
Sub KELİMELER()
    Dim X As Long, Y As Integer, Z As Byte, Satır As Long
    Dim Kelime() As String, Sembol() As Variant
    
    Application.ScreenUpdating = False
    Range("B:B").Clear
    Satır = 2
    Range("B1") = "Kelimeler"
    Range("B1").Font.Bold = True
    
    Sembol = Array(".", ",", "?", """", "<i>", "</i>")
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        If IsError(Cells(X, 1)) = False Then
            If Cells(X, 1) <> "" Then
                If IsNumeric(Mid(Cells(X, 1), 1, 1)) = False Then
                    Kelime = Split(Cells(X, 1), " ")
                    For Y = 0 To UBound(Kelime())
                        If Kelime(Y) <> "" Then
                            If Kelime(Y) <> "-" Then
                                Cells(Satır, 2) = Kelime(Y)
                                
                                For Z = 0 To UBound(Sembol())
                                    Cells(Satır, 2) = Replace(Cells(Satır, 2), Sembol(Z), "")
                                Next
                                
                                If Cells(Satır, 2) <> "" Then Satır = Satır + 1
                            End If
                        End If
                    Next
                End If
            End If
        End If
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Gorarr]

Tekrardan çok teşekkür ederim. Ellerinize sağlık. İyigeceler.