belli bir düzende satır bölme

[senolnl]

Merhaba arkadaşlar,
otomatik arama yapmak için bir veri tabanı oluşturmaya çalışıyorum... Veri çok fazla olduğu için elle yapmak imkansız....
Elimde şu formatta veriler var:

'schools n. : school
lives / lived / living v. : live
hours n. : hour
comes / coming / came / come n. : come'

Ben bu verileri belli bir düzene getirmem lazım. Getirmem gereken düzen şu şekilde:

'schools
n.
school

lives / lived / living
v.
live

hours
n.
hours

comes / coming / came / come
n.
come'

Bunun için aklıma gelen formül önce hücre bölmek geldi. 'v. ve n. karakterlerinden hücreleri böldüm. Ama bu kez örnek v. karakteri B1 e geçtiği için B1 i, A2 olarak yazmam lazım (bu arada yeni satırın A2 de ki text i silmeden yeni A2 satırı eklemem gerekiyor)... Böyle yapabilirsem A1 i, A1-A2-A3 e dağıtmış olacam daha sonra da aralara boş satır ekleyeceğim. A1 i A1-A2-A3 e dağıtmam için bir formül önerebilir misiniz?
Teşekkürler

 

[omerceri]

Sn senolnl Kodlar aşağıda. Orjinal dosyanızı yedekleyip, deneyin.

Sub Makro1()
    Sheets("Sheet1").Columns("A:A").Replace What:=" / ", Replacement:="/", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
     Sheets("Sheet1").Columns("A:A").TextToColumns Destination:=Sheets("Sheet1").Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
        ":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
       adres = Sheets("Sheet1").Range("A1").CurrentRegion.Address
       say = Sheets("Sheet1").Range(adres).Count
       For i = 1 To say
       Sheets("Sheet2").Range("A" & i).Value = Sheets("Sheet1").Range(adres)(i)
       Next
For e = say To 1 Step -1
       If e Mod 3 = 1 And e <> 1 Then
        Sheets("Sheet2").Rows(e & ":" & e).Insert Shift:=xlDown
        End If
       Next
End Sub

 

[senolnl]

tesekkurler