Hücreden sadece Harf olanları başka hücreye yazdırma

[hüseyintok]

Merhaba G kolonunda bulunan hücrelerdeki harf ve sayı karakteri birlikte olan hücrelerden (axd5587) gibi sadece Harf olan kısmını B kolonuna yazıdrmak istiyorum. Aşağıdaki kod çalışmıyor yardımcı olurmusunuz.

Sub CopyLetters()
Dim lastRow As Long
Dim i As Long lastRow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To lastRow
If IsLetter(Cells(i, "G").Value) Then
Cells(i, "B").Value = Cells(i, "G").Value
End If
Next i
End Sub

Function IsLetter(str As String) As Boolean
IsLetter = str Like "[A-Za-z]"
End Function

 

[excelokyanus500]

Deneyin.

Sub CopyLetters()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To lastRow

Cells(i, "B").Value = GetLettersOnly(Cells(i, "G").Value)

Next i
End Sub


Function GetLettersOnly(str As String) As String
    Dim result As String, objRegEx As Object, match As Object

    Set objRegEx = CreateObject("vbscript.regexp")

    objRegEx.Pattern = "[a-zA-Z]+"
    objRegEx.Global = True
    objRegEx.IgnoreCase = True

    If objRegEx.test(str) Then
        Set match = objRegEx.Execute(str)
        GetLettersOnly = match(0)
    End If
End Function

 

[hüseyintok]

Deneyin.

Sub CopyLetters()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To lastRow

Cells(i, "B").Value = GetLettersOnly(Cells(i, "G").Value)

Next i
End Sub


Function GetLettersOnly(str As String) As String
    Dim result As String, objRegEx As Object, match As Object

    Set objRegEx = CreateObject("vbscript.regexp")

    objRegEx.Pattern = "[a-zA-Z]+"
    objRegEx.Global = True
    objRegEx.IgnoreCase = True

    If objRegEx.test(str) Then
        Set match = objRegEx.Execute(str)
        GetLettersOnly = match(0)
    End If
End Function

Hocam teşekkürler. çalışıyor ama tablo çok uzun olduğu için çok uzun süre bekletiyor. daha kısa yolu yokmudur?

 

[muratboz06]

Deneyiniz.
Sub CopyLetters()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To lastRow

Cells(i, "B").Value = TextOnly(Cells(i, "G"))

Next i
End Sub

Function TextOnly(pWorkRng As Range) As String
Dim xValue As String
Dim OutValue As String
xValue = pWorkRng.Value
For xIndex = 1 To VBA.Len(xValue)
If Not VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Next
TextOnly = OutValue
End Function

 

[hüseyintok]

Sub CopyLetters()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To lastRow

Cells(i, "B").Value = TextOnly(Cells(i, "G"))

Next i
End Sub

Function TextOnly(pWorkRng As Range) As String
Dim xValue As String
Dim OutValue As String
xValue = pWorkRng.Value
For xIndex = 1 To VBA.Len(xValue)
If Not VBA.IsNumeric(VBA.Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & VBA.Mid(xValue, xIndex, 1)
End If
Next
TextOnly = OutValue
End Function

çok Teşekkürler Çalışıyor

 

[veyselemre]

Sub CopyLetters()
    Dim rng, r
    Set rng = Range("G1:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    If WorksheetFunction.CountA(rng) = 0 Then Exit Sub
    Set rng = rng.SpecialCells(xlCellTypeConstants)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d"
        .Global = True
        .IgnoreCase = True
        For Each r In rng
            If .test(r.Value) Then r.Offset(, -5).Value = .Replace(r.Value, "")
        Next
    End With
End Sub