Veri Ayır

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
Merhaba arkadaşlar. Tek hücredeki karışık veriyi satır ve sütunlara ayırmak istiyorum. Dosyada daha net anlaşılıyor. Cevaplarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Merhaba.

Aşağıdaki kod'u dener misiniz?
İç içe Split komutuyla da çözülebilirdi sanırım ama sütunlara ayırma kolayıma geldi.
NOT: Kod, H sütunundan itibaren sağa doğru 1'inci satırı kullanıyor, bu alanda veri varsa başka bir konuma alınız.
Rich (BB code):
Sub AYRISTIR_BRN()
Application.ScreenUpdating = False
[B1:F1].UnMerge: b2 = "no"
If Cells(Rows.Count, 3).End(3).Row > 2 Then Range("B3:F" & Rows.Count).ClearContents
If Cells(1, Columns.Count).End(xlToLeft).Column > 6 Then Range("G1:IV1").ClearContents
[B1].TextToColumns Destination:=[H1], DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Semicolon:=True, Comma:=False, Space:=False, Other:=False
Application.DisplayAlerts = False
For sut = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
    sat = Cells(Rows.Count, 2).End(3).Row + 1
    Cells(sat, 2) = Replace(Cells(1, sut), " ", "")
    Cells(sat, 2).TextToColumns Destination:=Cells(sat, 3), _
                    DataType:=xlDelimited, Other:=True, OtherChar:="-"
        If Len(Cells(sat, 3)) <> Len(Replace(Cells(sat, 3), ")", "")) Then
            ilk = WorksheetFunction.Search("(", Cells(sat, 3))
            Cells(sat, 5) = Replace(Mid(Cells(sat, 3), ilk + 1, 255), ")", "")
            Cells(sat, 3) = Mid(Cells(sat, 3), 1, ilk - 1)
        End If
        If Len(Cells(sat, 4)) <> Len(Replace(Cells(sat, 4), ")", "")) Then
            ilk = WorksheetFunction.Search("(", Cells(sat, 4))
            Cells(sat, 6) = Replace(Mid(Cells(sat, 4), ilk + 1, 255), ")", "")
            Cells(sat, 4) = Mid(Cells(sat, 4), 1, ilk - 1)
        End If
    Cells(sat, 2) = sut - 7
Next
Application.DisplayAlerts = True
If Cells(1, Columns.Count).End(xlToLeft).Column > 6 Then Range("G1:IV1").ClearContents
[B1:F1].Merge: Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub
 
Son düzenleme:

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
Ömer Bey cevabınız için teşekkür ederim. Kod sonuca götürüyor. Kodunuzu yarın detaylı inceleyeceğim. Bu saate kadar kodla uğraştım ama işin içinden çıkamadım. Kısmen çözdüm ama bazı yerlerde hata veriyor. Cevabınız için tekrardan teşekkür ederim.
 

turist

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
5,102
Excel Vers. ve Dili
2013 64Bit
English
Merhaba arkadaşlar. Tek hücredeki karışık veriyi satır ve sütunlara ayırmak istiyorum. Dosyada daha net anlaşılıyor. Cevaplarınız için şimdiden teşekkür ederim.
Sayın @Muhammet Okumuş ,
Dosyanız eklidir.
Örnek Sayfasında deneyiniz.
Not: Kodlar hızlıca düzenlenmiştir, kendiniz sadeleştirebilirsiniz.
 

Ekli dosyalar

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Tekrar merhaba.

Önceki cevabımdan farklı olarak;
ilgili alan dışında bir hücreye veri yazma, hücre ayırma/birleştirme/sütunlara dağıtma vs yok, sadece Split ve Replace komutu.
Böyle daha iyi oldu..
Rich (BB code):
Sub AYRISTIR_BRN2()
If Cells(Rows.Count, 3).End(3).Row > 2 Then Range("B3:F" & Rows.Count).ClearContents
satir = Len(Replace([B1], " ", "")) - Len(Replace(Replace([B1], " ", ""), ";", ""))
For ob = 0 To satir
    brn1 = Split(Split(Replace([B1], " ", ""), ";")(ob), "-")(0)
    brn2 = Split(Split(Replace([B1], " ", ""), ";")(ob), "-")(1)
    Cells(ob + 3, 2) = ob + 1
    If Len(brn1) <> Len(Replace(brn1, ")", "")) Then
        Cells(ob + 3, 5) = Replace(Split(brn1, "(")(1), ")", "")
            Cells(ob + 3, 3) = Replace(brn1, "(" & Replace(Split(brn1, "(")(1), ")", "") & ")", "")
                Else: Cells(ob + 3, 3) = brn1
                    End If
                    If Len(brn2) <> Len(Replace(brn2, ")", "")) Then
                Cells(ob + 3, 6) = Replace(Split(brn2, "(")(1), ")", "")
            Cells(ob + 3, 4) = Replace(brn2, "(" & Replace(Split(brn2, "(")(1), ")", "") & ")", "")
        Else: Cells(ob + 3, 4) = brn2
    End If
Next: MsgBox "İşlem tamamlandı.", 8, "..:: Ömer BARAN ::.."
End Sub
 
Son düzenleme:

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
Sn turist ve Ömer Bey, cevaplarınız için çok teşekkür ederim. Sorun sayenizde çözüme kavuştu.
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Estağfurullah.
Kolay gelsin.
.
 
Üst