Metin Kırpma

[bluefalcon]

Arkadaşlar merhaba,

Ekli dosyada bir miktar yol alabildiğim ancak sonrasında tıkandığım bir çalışma için yardımlarınızı rica edeceğim. Kendi çapımda bir kod silsilesi oluşturdum ancak yeterli olmadı maalesef, üstadların görüşlerini almanın bu noktada doğru olacağını düşündüm. Yardımcı olabilirseniz çok memnun olurum.

 

[Asri]

Kontrol ediniz.

Dim solstr, sagstr As String

Sub varyok()
Application.ScreenUpdating = False
  sonsatir = Cells(Rows.Count, "E").End(xlUp).Row + 1
  Range("F:F").Clear

  For i = 2 To sonsatir
    veri = Trim(Cells(i, "E").Value)
    Cells(i, "B").Value = ""
    Cells(i, "D").Value = ""
   
    If InStr(veri, "@") > 0 And InStr(veri, "1b") > 0 Then
       solstr = Trim(Mid(veri, InStr(veri, "@") + 1, Len(veri)))
       solstr = Trim(Mid(veri, 1, InStr(veri, "1b") - 1))
       solstr = cleanString(solstr)
       Cells(i, "B").Value = solstr
       If varmi(solstr) > 0 Then
          Cells(i, "F").Value = "VAR"
       Else
          Cells(i, "F").Value = "YOK"
       End If
    End If
   
    If InStr(veri, "#") > 0 Then
       veri = Trim(Mid(veri, InStr(veri, "#") + 1, Len(veri)))
       sagstr = Trim(Mid(veri, 1, Len(veri)))
       sagstr = cleanString(sagstr)
       Cells(i, "D").Value = sagstr
       If varmi(sagstr) > 0 Then
          Cells(i, "F").Value = "VAR"
       Else
          Cells(i, "F").Value = "YOK"
       End If
    End If
   
  Next i
  Application.ScreenUpdating = True
End Sub

'https://stackoverflow.com/questions/24356993/removing-special-characters-vba-excel
Function cleanString(text) As String
    Dim output As String
    Dim c 'since char type does not exist in vba, we have to use variant type.
    For i = 1 To Len(text)
        c = Mid(text, i, 1) 'Select the character at the i position
        If (c >= "a" And c <= "z") Or (c >= "0" And c <= "9") Or (c = "_" Or c = "-" Or c = ".") Then
            output = output & c 'add the character to your output.
        Else
            'output = output & " " 'add the replacement character (space) to your output
        End If
    Next
    cleanString = output
End Function

Function varmi(bilgi) As Long
    Set sayfak = Range("C:C").Find(bilgi, , xlValues, xlWhole)
    If Not sayfak Is Nothing Then
       varmi = sayfak.Row
       Exit Function
    End If
    varmi = 0
End Function

 

[veyselemre]

Sub test()
    Dim bl

    Range("B:B;D:D;F:F").Clear

    With CreateObject("VBScript.RegExp")
        .Pattern = "[^a-zA-Z0-9_@#.\s]"
        .Global = True
        For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
            For Each bl In Split(.Replace(Trim(Cells(i, "E").Value), ""), " ")
                If InStr(bl, "@") Then Cells(i, 2).Value = Replace(bl, "@", "")
                If InStr(bl, "#") Then Cells(i, 4).Value = Replace(bl, "#", "")
            Next bl
        Next i
    End With

    With Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Offset(, 3)
        .Formula = "=IF(COUNTIF(D:D,C2)+COUNTIF(B:B,C2),""VAR"",""YOK"")"
        .Value = .Value
    End With
   
End Sub

 

[bluefalcon]

Gerçekten çok teşekkür ederim, emeğinize ellerinize sağlık.