hücredeki text'teki değerleri sütuna yazdırma

[mersilen]

Merhabalar

Sütunda bulunan text değerleri içinde bulunan verileri seçtirerek yeni sütunlara yazdırmamız mümkün mü?
Yazım algoritmalarında belli düzen var ama konumları farklı olabilir.

İlgilenenlere şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub Veri_Al()
    Dim Son As Long, A As Long, B As Integer, C As Integer, D As Integer, Sutun As Byte
    Dim Veri_A  As Variant, Veri_B As String, Kriter As Variant, Veri_C As Variant
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("G2:Z" & Rows.Count).ClearContents
    
    For A = 2 To Son
        Veri_A = Split(Trim(Cells(A, 3)), Chr(10))
        
        For B = 0 To UBound(Veri_A)
            If Veri_A(B) = "" Then GoTo 10
            Select Case Left(Veri_A(B), 3)
                Case "BPD"
                    Sutun = 7
                Case "HC "
                    Sutun = 10
                Case "AC "
                    Sutun = 13
                Case "FL "
                    Sutun = 16
            End Select
            
            Veri_B = Replace(Veri_A(B), " ", "")
            Veri_B = Replace(Veri_B, "BPD", "")
            Veri_B = Replace(Veri_B, "AC", "")
            Veri_B = Replace(Veri_B, "HC", "")
            Veri_B = Replace(Veri_B, "FL", "")
            Veri_B = Replace(Veri_B, ".", "")
            
            Kriter = Array("mm", "hf", "gün")
            
            For C = 0 To UBound(Kriter)
                If Veri_B = "" Then Exit For
                Veri_C = Split(Veri_B, Kriter(C))
                
                For D = 0 To UBound(Veri_C) - 1
                    If IsNumeric(Left(Veri_C(D), 1)) Then
                        If Kriter(C) = "mm" Then
                            Cells(A, Sutun) = Veri_C(D)
                            Sutun = Sutun + 1
                            Veri_B = Replace(Veri_B, Veri_C(D) & Kriter(C), "")
                        End If
                        If Kriter(C) = "hf" Then
                            Cells(A, Sutun) = Veri_C(D)
                            Sutun = Sutun + 1
                            Veri_B = Replace(Veri_B, Veri_C(D) & Kriter(C), "")
                        End If
                        If Kriter(C) = "gün" Then
                            Cells(A, Sutun) = Veri_C(D)
                            Sutun = Sutun + 1
                            Veri_B = Replace(Veri_B, Veri_C(D) & Kriter(C), "")
                        End If
                    End If
                Next
            Next
10      Next
    Next

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ömer BARAN]

Merhaba.

Ben de formül ile çözüm önerisinde bulunayım dedim.
.

 

[mersilen]

Cevaplar için herkese teşekkür ederim.

Formülleri anlamaya çalışıyorum.

 

[Ömer BARAN]

Tekrar merhaba.

Bu da kod alternatifi olsun.

Aşağıdaki kod, eklediğim belgedeki formüllerin kod'a aktarılmış halidir.
Belgedeki yardımcı sütunlar (T:W) silinebilir.
.

[B]Sub BUL_DAGIT()[/B]
If Cells(Rows.Count, "G").End(3).Row > 1 Then Range("G2:R" & Rows.Count).ClearContents
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
    On Error Resume Next
    [B][COLOR="Red"]BPD[/COLOR][/B] = Evaluate("=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID($C" & _
        sat & ",FIND(G$1,$C" & sat & "),FIND(CHAR(10),$C" & sat & ",FIND(G$1,$C" & sat & "))-FIND(G$1,$C" & _
        sat & ")-6),""."","" ""),""mm"","" ""),""hf"","" ""),""gün"","" ""),G$1,""""))")
[COLOR="Blue"]    Cells(sat, "G") = Split([COLOR="Red"]BPD[/COLOR], " ")([B][COLOR="red"]0[/COLOR][/B]): Cells(sat, "H") = Split([COLOR="red"]BPD[/COLOR], " ")(1): Cells(sat, "I") = Split([COLOR="Red"]BPD[/COLOR], " ")([COLOR="red"]2[/COLOR])[/COLOR]
    [B][COLOR="red"]HC[/COLOR][/B] = Evaluate("=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID($C" & _
        sat & ",FIND(J$1,$C" & sat & "),FIND(CHAR(10),$C" & sat & ",FIND(J$1,$C" & sat & "))-FIND(J$1,$C" & _
        sat & ")-6),""."","" ""),""mm"","" ""),""hf"","" ""),""gün"","" ""),J$1,""""))")
[COLOR="Blue"]    Cells(sat, "J") = Split([COLOR="red"]HC[/COLOR], " ")([B][COLOR="red"]0[/COLOR][/B]): Cells(sat, "K") = Split([COLOR="red"]HC[/COLOR], " ")([B][COLOR="red"]1[/COLOR][/B]): Cells(sat, "L") = Split([COLOR="red"]HC[/COLOR], " ")([B][COLOR="Red"]2[/COLOR][/B])[/COLOR]
    [B][COLOR="red"]AC[/COLOR][/B] = Evaluate("=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID($C" & _
        sat & ",FIND(M$1,$C" & sat & "),FIND(CHAR(10),$C" & sat & ",FIND(M$1,$C" & sat & "))-FIND(M$1,$C" & _
        sat & ")-6),""."","" ""),""mm"","" ""),""hf"","" ""),""gün"","" ""),M$1,""""))")
[COLOR="Blue"]    Cells(sat, "M") = Split([COLOR="red"]AC[/COLOR], " ")([B][COLOR="red"]0[/COLOR][/B]): Cells(sat, "N") = Split([COLOR="red"]AC[/COLOR], " ")([B][COLOR="red"]1[/COLOR][/B]): Cells(sat, "O") = Split([COLOR="red"]AC[/COLOR], " ")([B][COLOR="Red"]2[/COLOR][/B])[/COLOR]
    [B][COLOR="red"]FL[/COLOR][/B] = Evaluate("=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID($C" & _
        sat & ",FIND(P$1,$C" & sat & "),FIND(CHAR(10),$C" & sat & ",FIND(P$1,$C" & sat & "))-FIND(P$1,$C" & _
        sat & ")-6),""."","" ""),""mm"","" ""),""hf"","" ""),""gün"","" ""),P$1,""""))")
[COLOR="Blue"]    Cells(sat, "P") = Split([COLOR="red"]FL[/COLOR], " ")([B][COLOR="red"]0[/COLOR][/B]): Cells(sat, "Q") = Split([COLOR="red"]FL[/COLOR], " ")([B][COLOR="red"]1[/COLOR][/B]): Cells(sat, "R") = Split([COLOR="red"]FL[/COLOR], " ")([B][COLOR="Red"]2[/COLOR][/B])[/COLOR]
Next
[B]End Sub[/B]