ALT + ENTER içeren hücredeki veriyi sütunlara ayrıştırmak

[mersilen]

Merhabalar,
Bir hücre içinde alt+enter ile oluşturulmuş satırlar halindeki bir metini sütunlara nasıl ayırırız?
Teşekkürler

Metin1:
Değer1 ,23456


Metin2:eğer2; gasdggdf


Metin3:
Değer 31 k,dgaghfhhf
Değer 32 :3Şdgdgdgg


Metin4: Değer440: gfdgfg
Değer441: gdsgDGDG

Değer442: fgffhhf

Değer443

 

[Muzaffer Ali]

Merhaba.

Sub test()
    Dim Deger As Variant
    Dim Sira As Integer
    Dim Satir As Integer
    Dim Bak As Long
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Satir = 1
        Deger = Split(Cells(Bak, "A"), Chr(10))
        For Sira = 1 To UBound(Deger)
            If Deger(Sira - 1) <> "" Then
                Satir = Satir + 1
                Cells(Bak, Satir) = Deger(Sira - 1)
            End If
        Next
    Next
    MsgBox "Tamamlandı."
End Sub

 

[veyselemre]

Sub cozumle()
    Dim i&, al$, veri, elem, kSira&
    Dim dic As Object, re As Object, m As Object

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(^Değer\d+)[\s,:;]+(.+)"
    re.Global = False
    re.IgnoreCase = True

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To 12
        dic.Add Cells(1, i).Value, i
    Next i

    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        al = Cells(i, 1).Value
        If al = "" Then GoTo devam
        al = Replace(al, "Değer  ", "Değer")
        veri = Split(al, Chr(10))
        For Each elem In veri
            kSira = InStr(elem, "Değer")
            If kSira > 0 Then
                elem = "Değer" & Trim(Replace(Mid(elem, kSira), "Değer", ""))
                Set m = re.Execute(elem)
                If m.Count > 0 Then
                    Set m = m(0).submatches
                    If dic.exists(m(0)) Then
                        Cells(i, dic(m(0))).Value = m(1)
                    End If
                End If
            End If
        Next elem
devam:
    Next i
    Set dic = Nothing: Set re = Nothing: Set m = Nothing
End Sub

 

[Korhan Ayhan]

Merhaba,

Eğer 1. satırdaki başlıklar önemliyse veyselemre beyin çözümü işinizi görecektir.

Başlıklar önemli değilse ve formülle çözüm isteseniz alternatif olsun.. B2 hücresine uygulayıp sağa doğru sürükleyiniz.

=KIRP(PARÇAAL(YERİNEKOY(DAMGA(10)&YERİNEKOY(YERİNEKOY(YERİNEKOY($A2;DAMGA(10)&DAMGA(10);DAMGA(10));DAMGA(10)&DAMGA(10);DAMGA(10));DAMGA(10)&DAMGA(10);DAMGA(10));DAMGA(10);YİNELE(" ";255));SÜTUN(A$1)*255;255))

 

[mersilen]

Hocalarım merhaba,
Geç cevap yazdım kusura bakmayın.
Kodlarda değişik hatalar oldu, biraz üzerinde çalıştım , hatta python pandas ile çözerim dedim olmadı.(excel satır okuma katası verdi)
Şöyle ki;
-Ana veri 10 000 satır civarı
-Hücrelerdeki kalıplar standart değil
-"\n\n" ve "\n\n\n" standart değil (bu ecelde sorun oluyor. Bunu "\n" yapıyım dedim olmadı.
-Tablodaki sütun başlıkları standart, bu başlıklar altına içerdikleri satırları yazdırabilir miyiz?
-Mümkünse hücredeki satırlar tek "\n" içermeli , bu aşağıdaki kod excelde çalışmadı.

strSubtitute = Application.WorksheetFunction.Substitute _
(Arg1:=strCurrent, Arg2:="\n\n", _
Arg3:="")

Sub SubstituteText()
Dim strCurrent As String
Dim strSubtitute As String
strCurrent = Cells(3, "a").Value
MsgBox "The current string is: " & strCurrent

strSubtitute = WorksheetFunction.Substitute(strCurrent, Chr(10) & Chr(10), "")

MsgBox "The replaced string is: " & strSubtitute
Cells(3, "b").Value = strSubtitute
      
End Sub

Buda düzenli çalışmıyor


Orginal dosyanın bir kısmını yükledim
Bende ki excel orginal değil, MS pro plus 2016
Yardımlarınız için şimdiden teşekkürler

-