DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub AKTAR()
Set WF = WorksheetFunction
[B:B].ClearContents
For X = 1 To [A65536].End(3).Row
If Cells(X, 1) <> "" Then
Cells(X, 2) = Mid(Cells(X, 1), 1, WF.Search("GR", Cells(X, 1), 1) + 1)
End If: Next
Set WF = Nothing
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub
Public Sub Bul_Yaz()
On Error Resume Next
For i = 1 To [a65536].End(3).Row
Bul = 0
Bul = Application.WorksheetFunction.Find("gr", Cells(i, "A"))
If Bul > 0 Then
Cells(i, "B") = Left(Cells(i, "A"), Bul + 2)
End If
Next i
End Sub
Merhaba.arkadaşlar
örnek :
excel123graaaa
excel12asgradad
bu şekilde olan hücrelerde gr den önceki bölümü nasıl ayırıp başka bir hücreye yapıştırabilirm. makro ile
excel123gr
excel12asgr
Sub ayir()
Dim sonsat As Long, i As Long, sat As Long
Dim harf As String, kelime As String
Sheets("Sayfa1").Select
Range("B:B").ClearContents
sonsat = Cells(65536, "A").End(xlUp).Row
sat = 1
For i = 1 To sonsat
If Cells(i, "A").Value <> "" Then
For k = 1 To Len(Cells(i, "A").Value)
harf = Mid(Cells(i, "A").Value, k, 1)
If harf = "g" And Mid(Cells(i, "A").Value, k + 1, 1) = "r" Then
Cells(sat, "B").Value = kelime
sat = sat + 1
harf = "": kelime = "": Exit For
Else
kelime = kelime & harf
End If
Next k
End If
Next i
MsgBox "İŞLEM TAMAM"
End Sub
Sub harfayir()
Set deg = CreateObject("VBscript.RegExp")
deg.Pattern = "[^a-zA-Z\çÇ\ğĞ\ıİ\öÖ\şŞ\üÜ ]"
deg.Global = True
For a = 1 To [a65536].End(3).Row
Cells(a, "b") = Trim(deg.Replace(Cells(a, "a"), ""))
Next
Set deg = Nothing
End Sub
Aşağıdaki kodu deneyin.
Kod:Sub harfayir() Set deg = CreateObject("VBscript.RegExp") deg.Pattern = "[^a-zA-Z\çÇ\ğĞ\ıİ\öÖ\şŞ\üÜ ]" deg.Global = True For a = 1 To [a65536].End(3).Row Cells(a, "b") = Trim(deg.Replace(Cells(a, "a"), "")) Next Set deg = Nothing End Sub