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

-

 

[Muzaffer Ali]

1- Eğer gerekiyorsa başlıkları artırıp eksiltebilirsiniz.
2- Başlıkta "MAKROSKOBİK BULGULAR" yazıyor fakat rapor içinde bazı yerlerde "MAKROSKOPİK BULGULAR" yazıyor (PİK <> BİK).
Ben hepsini bul değiştir ile "MAKROSKOBİK" yazarak çalıştırdım sorunsuz çalışıyor. Bunun gibi tek bir harf bile farklı olsa yanlış sonuç dönecektir. Bilginize.

Sub test()
    Dim Basliklar As Variant
    Dim BaslikSay As Integer
    Dim BasBak As Integer
    Dim Rapor As Variant
    Dim Deger As String
    Dim Bak As Long
    Dim Parca As Variant
   
    BaslikSay = Cells(1, Columns.Count).End(xlToLeft).Column
    Basliklar = Range("B1:" & Cells(1, BaslikSay).Address).Value
   
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For BasBak = 1 To BaslikSay - 1
            Parca = Split(Cells(Bak, "A"), Basliklar(1, BasBak) & ":")
            If UBound(Parca) > 0 Then
                Deger = Parca(1)
            Else
                Deger = ""
            End If
            If BaslikSay > BasBak + 1 Then
                Parca = Split(Deger, Basliklar(1, BasBak + 1) & ":")
                If UBound(Parca) > 0 Then Deger = Parca(0)
            End If
            Cells(Bak, BasBak + 1) = Deger
        Next
    Next
    MsgBox "Tamamlandı."
End Sub