Sütundaki isimleri koşullu olarak yan sütuna kopyalama ?

[Gorarr]

Selamlar, aslında benzer bir konudan yardım almıştım ama onu sadeleştiremedim. Mecburen tekrar soru açtım.
Yapmak istediğim, "A sütunundaki "isimlerini herhangi bir rakam başlayana kadar ki kısmının B sütuna kopyalanması.

Örn."A" sütununda:
the.battleground.2012.mkv
the.matrix.1080p.mkv
a.bus's.life720p.2002.avi

Bunların "B" sütununa :
the.battleground.
the.matrix.
a.bug's.life


şekilde topluca kopyalamam gerekiyor. (noktalar önemli değil)

Bu arada daha önce Necdet hoca daha kompleks bir yöntemle (klasörden dosya isimlerini kopyalayarak) yapmıştı. Ben bu kodları sadeleştirip yukarıda istedğim şekle getiremedim.

Yardımlarınız için şimdiden çok çok teşekkür ederim.

Sub DosyaListele()

Dim Yol As String, _
Dosya As String, _
Dsy As String, _
i As Long, _
j As Integer


Application.ScreenUpdating = False
Yol = "C:\Filmler\"

Dosya = Dir(Yol & "*.*")
Range("A:A").ClearContents
i = Cells(Rows.Count, "A").End(3).Row

While Dosya <> ""
i = i + 1
j = 1
For j = 1 To Len(Dosya)
If IsNumeric(Mid(Dosya, j, 2)) = True Then Exit For
Next j
If Mid(Dosya, j - 1, 1) = "." Then j = j - 1
Cells(i, "A") = Left(Dosya, j - 1)
Dosya = Dir
Wend

Application.ScreenUpdating = True
MsgBox i - 1 & " ADET DOSYA LİSTELENMİŞTİR...", vbInformation, "N. YEŞERTENER"

End Sub

 

[bedersu]

Sayın Gorarr,
Necdet Bey'in kodları zaten işi halletmiş.Ben biraz değiştirdim,belki biraz da uzattım ama işinizi görür sanırım.

 Sub listele()
 On Error GoTo son:
a = Cells(Rows.Count, "A").End(3).Row
i = 1
Dosya = Cells(i, 1)

While Dosya <> ""
Dosya = Cells(i, 1)
j = 1
For j = 1 To Len(Dosya)
If IsNumeric(Mid(Dosya, j, 2)) = True Then Exit For
Next j
If Mid(Dosya, j - 1, 1) = "." Then j = j - 1
Cells(i, "B") = Left(Dosya, j - 1)
i = i + 1
Wend
son:
 End Sub

 

[Gorarr]

Çok teşekkür ederim. Saygılar.