metinden parça alma

[ahmet altan]

arkadaşlar merhaba,


ekte gönderdiğim dosyada D sütunundaki metindeki kırmızıyla boyalı ola parçaları almak istiyorum... parça alla denedim ama her hücreye ayrı ayrı uygulamam gerek çünkü karakter sayıları her hücrede farklı.. formülü aşağı doğru çektiğimde işe yaramıyor

 

[Civan Jack]

Sub Ayir()
    Dim i As Integer
    Dim s As Variant
    For i = 2 To Range("A65536").End(3).Row
        s = VBA.Split(Cells(i, 4), ",")
        If VBA.Left(Cells(i, 4), 1) <> 0 Then
            Cells(i, "h") = s(0)
            Cells(i, "ı") = s(2)
                Else
            Cells(i, "h") = s(1)
            Cells(i, "ı") = s(4)
        End If
    Next i
End Sub

 

[ahmet altan]

yaa makro yazmayı hiç bilmiyorum formülle yapabilirmiyim yada bu kodları vba olarak yazılcağını söylerseniz daha sevinirim...

 

[Civan Jack]

dosyayı açın alt+f11e basın yukarıdaki insert menüsünden module yi seçin şimdi verdiğim kodları kopyalayıp oraya yapıştırın ve f5 e basın.

 

[ahmet altan]

yaptım oldu ama bu 185 tane alt altata satırdan oluşuyor

Cells(i, "h") = s(0) f5 e başınca sarı uyarı veriyor bu formül neden ?

 

[Merhum İdris SERDAR]

arkadaşlar merhaba,


ekte gönderdiğim dosyada D sütunundaki metindeki kırmızıyla boyalı ola parçaları almak istiyorum... parça alla denedim ama her hücreye ayrı ayrı uygulamam gerek çünkü karakter sayıları her hücrede farklı.. formülü aşağı doğru çektiğimde işe yaramıyor

.

Dosyanız ekte.

KTF'lerle yapılmıştır.

KTF kodları aşağıdaki verilmiştir.

Renkli ifadeleri almak için:

Function RenkSoz(hcr As Range, renk As Integer)

Dim i As Integer
RenkSoz = ""
With hcr
For i = 1 To Len(hcr.Text)
With .Characters(i, 1).Font
If .ColorIndex = renk Then
RenkSoz = RenkSoz & Mid(hcr.Text, i, 1)

End If
End With
Next i
End With

End Function

Renkli ifadeler bir hücreye alındıktan sonra rakamları ayırmak için:

Function Rakam(hcr As Range)

    For a = 1 To Len(hcr)
    If IsNumeric(Mid(hcr, a, 1)) Then son = son & Mid(hcr, a, 1)
    Next
    son = IIf(son = 0, "Rakam yok.", son * 1)
    Rakam = son
    
End Function

Harfleri ayırmak için:

Function Harf(hcr As Range)

    For a = 1 To Len(hcr)
    If Not IsNumeric(Mid(hcr, a, 1)) Then son = son & Mid(hcr, a, 1)
    Next
    son = IIf(son = 0, "Harf yok.", son)
    Harf = son
    
End Function

.

 

[Civan Jack]

yaptım oldu ama bu 185 tane alt altata satırdan oluşuyor

Cells(i, "h") = s(0) f5 e başınca sarı uyarı veriyor bu formül neden ?

Kodlara On Error Resume Next satırını ilave ettim. Gelenlere bakın istediğinizden farklı değerler geliyorsa daha geniş bir dosya gönderin bakalım.

Sub Ayir()
Dim i As Integer
Dim s As Variant
On Error Resume Next
For i = 2 To Range("A65536").End(3).Row
s = VBA.Split(Cells(i, 4), ",")
If VBA.Left(Cells(i, 4), 1) <> 0 Then
Cells(i, "h") = s(0)
Cells(i, "ı") = s(2)
Else
Cells(i, "h") = s(1)
Cells(i, "ı") = s(4)
End If
Next i
End Sub