.txt dosyasını excele çevirmek

[mersilen]

Merhabalar

Cep telefonu rehberini bilgisayara txt dosyası olarak alabiliyorum.
Bunu excele çevirip excelde düzenledikten sonra tekrar telefona yükleyebiliyorum.

Bu çalışmada en önemli yerlerden biri olan txt dosyasını excele sıralı ve doğru atacak macro koduna ihtiyacım var.(Mevcut rehberlerin büyüklüğü düşünülürse manuel yapılması zor)

dosya txt den excele çevirme.rar da mevcut .Sayfa 2 sayfa 4 de oluşturulacak.
Dosyalar 2. mesajda güncellendi.

 

[mersilen]

Tekrar merhabalar
Kendi mantığımca bir kod yazdım ama hata veriyor.
X=3 leri almıyor.
Düzeltmemiz mümkün mü?
Dosyaları daha anlaşılır şekilde yeniden düzenledim
kodu çalıştırınca a sütunu "1.Adı:" da kalıyor.

Sub dene()
Dim i, x, sut As Integer

For x = 2 To WorksheetFunction.CountIf(Worksheets("sayfa2").Cells("A:A"), "Adı:")

   For i = 1 To Worksheets("sayfa2").Cells(Rows.Count, "A").End(xlUp).Row
     If Worksheets("sayfa2").Cells(i, "A").Value <> "" Then
   
     sut = WorksheetFunction.Match(Worksheets("sayfa2").Cells(i, "A").Value, Rows(1), 0)
     Cells(x, sut) = Worksheets("sayfa2").Cells(i, "B")
     Else: GoTo altsatırageç
     End If
   Next i
altsatırageç:
Next x
End Sub

Sub dene()
Dim i, x, sut As Integer
Application.Calculation = xlManual
Application.ScreenUpdating = False
Range("a4", "az10") = Clear: Range("a19:a35") = Clear


For x = 2 To WorksheetFunction.CountIf(Worksheets("sayfa2").Range("A:A"), "Adı:")
   For i = 1 To Worksheets("sayfa2").Cells(Rows.Count, "A").End(xlUp).Row
     If Worksheets("sayfa2").Cells(i, "A").Value = "" Then GoTo altsatırageç Else
     sut = WorksheetFunction.Match(Worksheets("sayfa2").Cells(i, "A").Value, Rows(1), 0)
     Cells(x, sut) = Worksheets("sayfa2").Cells(i, "B")
 
   Next i
altsatırageç:
Next x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub