Metin içinde ara yapıp , istenilenleri alt alta listeleme

[ozgretmen]

Sorum ekte.Yardımlarınızı bekliyorum.İyi çalışmalar...

 

[hamitcan]

Aşağıdaki kodu dener misiniz ?
Not: A1 hücresinin başına " '-(tırnak eksi)" işareti koyun.

Sub ayir()
[a3:e50].Clear
    [A1].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=")", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
    
    son = Columns(256).End(xlToLeft).Column
    c = 2
    For i = 1 To son
    c = c + 1
    Cells(c, 1) = Cells(1, i)
            a = Split(Cells(c, 1), "-")
            d = 0
            For ii = 0 To UBound(a)
               d = d + 1
               If a(ii) <> "" Then Cells(c, d) = a(ii)
            Next
    Cells(c, 2) = "'" & Mid(Cells(c, 1), 14, 6)
    Cells(c, 1) = "'" & Mid(Cells(c, 1), 3, 10)
    Next
End Sub

 

[ozgretmen]

İlginiz için Teşekkürler sayın hamitcan. Çalıştı ama eksik oldu.Ama kodlarınızı inceleyip bir şeyler oluşturmaya çalışacağım.Belki hallderim...

 

[Orion1]

Ekli dosyayı denermisiniz.

Sub a()
Dim k As Collection, j As Collection
Set k = New Collection
Set j = New Collection
On Error Resume Next
b = Split(Range("A1").Value, "-")
say = 1
Range("A3:E65536").ClearContents
For i = LBound(b) To UBound(b)
        k.Add Replace(b(i), ")", "")
Next
For i = 1 To k.Count
If say > 5 Then say = 1
    If say = 1 Then
        d = Split(k.Item(i), ":")
        j.Add Replace(d(0), "(", "")
        j.Add d(1)
        say = 3
        ElseIf say > 2 Then
        j.Add k.Item(i)
        say = say + 1
    End If
Next i
sut = 1
sat = 3
For i = 1 To j.Count
    If sut > 5 Then sut = 1: sat = sat + 1
    If sut = 1 Then
        Cells(sat, sut).Value = CDate(j.Item(i))
        ElseIf sut = 2 Or sut = 4 Or sut = 5 Then
            Cells(sat, sut).Value = CDbl(j.Item(i))
            Else
            Cells(sat, sut).Value = j.Item(i)
    End If
    
    sut = sut + 1
Next
MsgBox "işlem tamamdır."
End Sub

 

[ozgretmen]

Sayın Evren Gizlen çok ama çok teşekkürler...Birde bu kodların yanlarında açıklamları olsa ne kadar da iyi olurdu. Ama neyse ...Satır satır ben bu kodları yiyip içeceğim. İyi çalışmalar...:hey:

 

[Orion1]

Sayın Evren Gizlen çok ama çok teşekkürler...İyi çalışmalar...

Rica ederim.
İyi çalışmalar.