Soru Metin içinden istenilen verileri çekme

[mehmetd]

Sayın, arkadaşlar hayırlı günler. ekteki örnek çalışmamdaki soruyu bir türlü yapamadım yardımınız için şimdiden teşekkür ederim

 

[tahsinanarat]

Fonksiyon ve makro ile çözüm ekli dosyada. Hücre seçili iken düğmeye basınız.

 

[mehmetd]

Sn. tahsinanarat Bey teşekkür ederim verileri mi dosyaya yapıştırıdım düğmeye bastım olmadı. nerde hata yapıyorum acaba 4-5 örnek ekledim ekteki dosyaya.

 

[Ali]

Aşağıdaki kodları dener misiniz

Sub AdresBilgileriniAyir_SayinSonrasiUnvan()

    Dim ws As Worksheet
    Dim i As Long
    Dim satirlar() As String
    Dim hucre As Range
    Dim unvan As String, adres As String, vd As String, no As String
    Dim satir As String

    Set ws = ThisWorkbook.Sheets(1)

    For Each hucre In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        If hucre.Value <> "" Then
            ' Satırları ayır
            satirlar = Split(hucre.Value, vbLf)
            unvan = ""
            adres = ""
            vd = ""
            no = ""

            For i = LBound(satirlar) To UBound(satirlar)
                satir = Trim(satirlar(i))
                
                If satir = "" Then GoTo DevamEt

                If InStr(satir, "Sayın") > 0 Then
                    ' "Sayın," ifadesinden sonra gelen kısmı unvan olarak al
                    If Len(satir) > 6 Then
                        unvan = Trim(Mid(satir, InStr(satir, "Sayın") + 6))
                    End If
                ElseIf unvan = "" And InStr(satir, "/") > 0 Then
                    unvan = satir
                ElseIf InStr(satir, "Müşteri V.D") > 0 Then
                    If InStr(satir, "No:") > 0 Then
                        vd = Trim(Split(Split(satir, "Müşteri V.D:")(1), "No:")(0))
                        no = Trim(Split(satir, "No:")(1))
                    Else
                        vd = Trim(Replace(satir, "Müşteri V.D:", ""))
                    End If
                Else
                    adres = adres & satir & " "
                End If
DevamEt:
            Next i

            ' Sonuçları yaz
            hucre.Offset(0, 1).Value = unvan
            hucre.Offset(0, 2).Value = Trim(adres)
            hucre.Offset(0, 3).Value = vd
            hucre.Offset(0, 4).Value = no
        End If
    Next hucre

    MsgBox "Ayrıştırma tamamlandı.", vbInformation

End Sub

 

[mehmetd]

Sn. Ali Bey çok teşekkür ederim.