Ayrıştırarak metne dönüştür2

[meleklerim]

Daha önce aynı konuda açtığım soruna aşağıdaki makroyu kullanarak sağolsun Kuvari Bey yardımcı olmuştu.
Ancak şimdi verilerime 1 sütun daha eklendi.

Yeniden makro oluşturmaktansa mevcut makro üzerinde düzenleme yapmak daha kolay olur diye düşünüyorum

Sub böl()
x = 1
For Each alan In Sayfa1.Range("b2:b" & Sayfa1.Cells(Rows.Count, "b").End(3).Row)

a = VBA.Split(alan.Value, "@")

For Each metin In a

x = x + 1

b = Split(metin, ";")
Sayfa2.Range("a" & x) = alan.Offset(, -1).Value
Sayfa2.Range("b" & x).Resize(, 2) = b

Next
Next

End Sub

yardımcı olacak arkadaşlara şimdiden teşekkürler

örnek dosya
http://s6.dosya.tc/server7/luozem/bol3sutun.xlsx.html

veriler "mavilistele" sayfasında, makro sonucu "maviböl" sayfasındaki sonucu elde etmek istiyorum

 

[Erdem Akdemir]

Merhaba,

Örnek dosyanızı http://www.dosyaupload.com/ adresine yükleyebilir misiniz.

 

[meleklerim]

http://www.dosyaupload.com/Y1a

buyrun kuvari bey,
yine hızır gibi yetiştiniz

 

[Erdem Akdemir]

Deneyebilir misiniz.

Kod dinamik hale gelmiştir. 2 ve 3'lü bilgileri aynı anda deneyebilirsiniz.

Sub böl()
Sayfa2.Cells.Clear
x = 1
For Each alan In Sayfa1.Range("b2:b" & Sayfa1.Cells(Rows.Count, "b").End(3).Row)

a = VBA.Split(alan.Value, "@")

For Each metin In a

x = x + 1

b = Split(metin, ";")
Sayfa2.Range("a" & x) = alan.Offset(, -1).Value
Sayfa2.Range("b" & x).Resize(, UBound(b) + 1) = b

Next
Next

End Sub

 

[meleklerim]

Kuvari bey,
pardon makro çalışıyormuş,
elinize sağlık
çok teşekkürler,
süpersiniz