sutun içindeki belli bir karakter ile sıralama

[can-can]

Merhaba youtube playlistin içindeki title=) yazan sayıya göre sıralama yapamadım yardımcı olur musunuz teşekkürler...

burdaki sayılar link bozulmayacak şekilde ;title=1),title=2) şeklinde sıralanması gerek bunun için bir formul , makro vs.. nasıl yapabilirim çok teşekkür ederim...

örnek;
http://dosya.co/ijcvubw1h0rq/örnek.xlsx.html

 

[halit3]

B Sutün yardımcı olarak kullanılmıştır.

kod:

Sub sırala()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Columns("b").ClearContents

For r = 1 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = "title"
adres = Cells(r, 1).Value
say = InStr(Trim(adres), AlinacakVeri)
adres2 = WorksheetFunction.Trim(Mid(adres, say + 6, Len(adres)))
deg = InStr(Trim(adres2), ")")
Cells(r, "b").Value = WorksheetFunction.Trim(Mid(adres2, 1, deg - 1))
Next r

ad = 1 & ":" & Cells(Rows.Count, "a").End(3).Row
Rows(ad).Select
Rows(ad).Sort Key1:=Cells(2), Order1:=xlAscending
Columns("b").ClearContents
Range("b1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

 

[can-can]

B Sutün yardımcı olarak kullanılmıştır.

kod:

Sub sırala()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Columns("b").ClearContents

For r = 1 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = "title"
adres = Cells(r, 1).Value
say = InStr(Trim(adres), AlinacakVeri)
adres2 = WorksheetFunction.Trim(Mid(adres, say + 6, Len(adres)))
deg = InStr(Trim(adres2), ")")
Cells(r, "b").Value = WorksheetFunction.Trim(Mid(adres2, 1, deg - 1))
Next r

ad = 1 & ":" & Cells(Rows.Count, "a").End(3).Row
Rows(ad).Select
Rows(ad).Sort Key1:=Cells(2), Order1:=xlAscending
Columns("b").ClearContents
Range("b1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

Çok çok teşekkür ederim.

 

[can-can]

Çok çok teşekkür ederim.

Hocam, size örnekte vermiş olduğum dosya haricinde başka playlistlerde yapamadım yardım eder misiniz

almış olduğum hata ;

 

[can-can]

B Sutün yardımcı olarak kullanılmıştır.

kod:

Sub sırala()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Columns("b").ClearContents

For r = 1 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = "title"
adres = Cells(r, 1).Value
say = InStr(Trim(adres), AlinacakVeri)
adres2 = WorksheetFunction.Trim(Mid(adres, say + 6, Len(adres)))
deg = InStr(Trim(adres2), ")")
Cells(r, "b").Value = WorksheetFunction.Trim(Mid(adres2, 1, deg - 1))
Next r

ad = 1 & ":" & Cells(Rows.Count, "a").End(3).Row
Rows(ad).Select
Rows(ad).Sort Key1:=Cells(2), Order1:=xlAscending
Columns("b").ClearContents
Range("b1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

Hocam, size örnekte vermiş olduğum dosya haricinde başka playlistlerde yapamadım yardım eder misiniz

almış olduğum hata ;

 

[halit3]

Kod örnek dosyanızda çalışıyor

kodun çalışmadığı dosyayı yükleyin bir bakalım.

 

[can-can]

Kod örnek dosyanızda çalışıyor

kodun çalışmadığı dosyayı yükleyin bir bakalım.

Evet hocam size verdiim örnekteki linklerde çalışıyor fakat ben başka playlist denemek istediğimde hata alıyorum.

örnek 1;
http://dosya.co/fekxlrq7t1no/örnek_1.xlsx.html

örnek2:

http://dosya.co/0dt1ohwkyhsy/örnek_2.xlsx.html

 

[halit3]

İlgili dosyadaki sayfada 11 ve 20 satırdaki veriler de title den sonra sayı yok onun için kod hata veriyor

Bu kodu bir dene kırmızı bölümün başındaki tırnak işaretini kaldırırsanız B sutündaki veriler silinecektir.

Sub sırala()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Columns("b").ClearContents
On Error Resume Next
For r = 1 To Cells(Rows.Count, "a").End(3).Row

AlinacakVeri = "title"
adres = Cells(r, 1).Value
say = InStr(Trim(adres), AlinacakVeri)
adres2 = WorksheetFunction.Trim(Mid(adres, say + 6, Len(adres)))
deg = InStr(Trim(adres2), "%")
Cells(r, "b").Value = Replace(WorksheetFunction.Trim(Mid(adres2, 1, deg - 1)), ")", "")
Next r
MsgBox 1
ad = 1 & ":" & Cells(Rows.Count, "a").End(3).Row
Rows(ad).Select
Rows(ad).Sort Key1:=Cells(2), Order1:=xlAscending
[COLOR="Red"]'Columns("b").ClearContents[/COLOR]
Range("b1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"

End Sub

 

[halit3]

kod işinizi gördü mü ?