sıralama tablosu oluşturmak

[pisagor84]

konunun yeri burasımı emin değilim ama derdimi anlatayım çözüm yolu gösterirseniz sevinirim.

bir siteden yarış sonuçlarını alarak(csv olarak günlük manuel alabiliyorum ancak geriye dönük tüm sonuçları tek tek almak çok zahmetli olacak kısa yolu varmı) excellde toplamak istiyorum. Sonra bir sonraki yarışta derece,pilot,pist gibi özelliklerinide hesaplayan bir formül ile yeni yarıştaki diğer rakiplerine göre puanlamasını yapmak istiyorum.

excellde webden veri al ile o siteden veri alamadım.Sadece anasayfayı tickliyebiliyorum.

bunun için program bilmelimiyim yoksa excellde halledebilirmiyim. Yardımcı olabilirmisiniz.

 

[pisagor84]

aşağıdaki siteden verileri almak için webden veri alı kullandım mesela excele aldım

http://www.tjk.org/TR/YarisSever/Query/ConnectedPage/AtKosuBilgileri?QueryParameter_Yil=-1&QueryParameter_SehirId=-1&QueryParameter_PistKodu=-1&QueryParameter_MesafeStart=-1&QueryParameter_MesafeEnd=-1&Sort=s20&OldQueryParameter_AtId=53154

ama sondaki numara 0 dan 200000 ekadar gidiyor ve her biri için ayrı sayfa mevcut bunları toplu olarak alacak bir yol varmı

 

[pisagor84]

aşagıdaki kod ile siteden bilgileri almayı başardım ama gereksiz bilgiler var ben sadece atın adı ve tarih,koşu bilgilerini almak istiyorum(şehir,derece,mesafe,jokey) onları nasıl süzebilirim birde id de güncelleme varsa onun eklemesini istiyorum

Sub guncelle2()
Dim i As Byte
Dim son As Long
Dim adr As String
adr = "http://www.tjk.org/TR/YarisSever/Query/ConnectedPage/AtKosuBilgileri?1=1&QueryParameter_AtId="
For i = 1 To 3
son = Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1
With ActiveSheet.QueryTables.Add("URL;" & adr & i, Range("A" & son))
.Name = "data.php="
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next i

 

[rafetyasar]

kodun devamı eksik

 

[ermanay]

Arkadaşlar bu kodlardan yola çıkarak. Aşağıdaki kodları ekledim. Sadece At_Id'ye göre bir yazılım yaparak , veri tabanı oluşturabilirsiniz. Konunun üzerinden 1 sene kadar geçmiş ama ben de bir veri tabanı oluşturabilirim diye araştırırken gördüm. Bol kazançlar.

Private At_Id As Long
Sub guncelle2()
At_Id = 12
Application.ScreenUpdating = False
Call allert
Dim i As Byte
Dim son As Long
Dim adr As String
adr = "https://www.tjk.org/TR/YarisSever/Query/ConnectedPage/AtKosuBilgileri?1=1&QueryParameter_AtId="
With ActiveSheet.QueryTables.Add("URL;" & adr & At_Id, Range("A1"))
.Name = "data.php="
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Call sil
Call değiştir
Call yerleştir
Application.ScreenUpdating = True
If Right(Range("b1"), 6) = "(Öldü)" Then MsgBox "ölmüş"
End Sub
Sub allert()
On Error Resume Next
Application.DisplayAlerts = False
Range("a1").Select
Selection.QueryTable.Delete
Selection.QueryTable.Delete
Selection.QueryTable.Delete
Selection.ClearContents
Application.DisplayAlerts = True

End Sub
Sub sil()
Rows("1:78").Delete Shift:=xlUp
End Sub
Sub değiştir()


Rows("11:30").Delete Shift:=xlUp
Rows("13:15").Delete Shift:=xlUp
For a = 1 To 300
If Range("a" & a) = "Başa Dön" Then Exit For
Next
Rows(a & ":" & 130).Delete Shift:=xlUp

End Sub
Sub yerleştir()
Range("A1:A10").Cut Destination:=Range("B1:B10")
Range("A1").FormulaR1C1 = "Atın İsmi"
Range("A2").FormulaR1C1 = "Yaş"
Range("A3").FormulaR1C1 = "Doğum Tarihi"
Rows("4:4").Delete Shift:=xlUp
Range("A4").FormulaR1C1 = "Baba"
Range("A5").FormulaR1C1 = "Anne"
Range("A6").FormulaR1C1 = "Antrenör"
Range("A7").FormulaR1C1 = "Gerçek Sahip"
Range("A8").FormulaR1C1 = "Üzerine Koşan Sahip"
Range("A9").FormulaR1C1 = "Yetiştirici"
Range("A10").FormulaR1C1 = "index"
Rows("11:11").Insert Shift:=xlDown
Range("b1") = Right(Range("b1"), Len(Range("b1")) - 4)
Range("b2") = Right(Range("b2"), Len(Range("b2")) - 3)
Range("b3") = Mid(Range("b3"), 9, 10)
Range("b4") = Right(Range("b4"), Len(Range("b4")) - 4)
Range("b5") = Right(Range("b5"), Len(Range("b5")) - 4)
Range("b6") = Right(Range("b6"), Len(Range("b6")) - 8)
Range("b7") = Right(Range("b7"), Len(Range("b7")) - 13)
Range("b8") = Right(Range("b8"), Len(Range("b8")) - 20)
Range("b9") = Right(Range("b49"), Len(Range("b9")) - 12)
Range("b10") = At_Id
End Sub