![]() |
| ![]() |
|
DUYURU SİSTEMİ / REKLAM PANOSU |
Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
![]() |
![]() |
|
Paylaş | Konu Araçları | Görünüm Modları |
![]() |
#1 |
Altın Üye
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,781
Excel Vers. ve Dili:
Ofis 2016 Türkçe |
![]() http://www.excel.web.tr/f48/web-sayf...k-t121692.html
Yukarıdaki linkde Sn. Halit Beyin kodları http://www.excel.web.tr/f48/web-sayfasyndan-900-sayfalyk-veriye-cekmek-t121692.html Option Explicit Sub VERİ_AL() Dim SAYFA As Worksheet, X As Long, URL_LİNK As String Dim sat Application.ScreenUpdating = False For Each SAYFA In Worksheets If SAYFA.Name <> "Sayfa1" Then Application.DisplayAlerts = False SAYFA.Delete Application.DisplayAlerts = True End If Next For X = 1 To 5 URL_LİNK = "http://www.otoerdem.com/tamliste/ren...liste.php?page=" & X & "¶m1=valu1¶m2=value2" sat = Sheets("Sayfa1").Range("A65536").End(3).Row + 1 'URL_LİNK = Sheets("Sayfa1").Cells(X, 1) ActiveWorkbook.Worksheets.Add , After:=Sheets(Worksheets.Count) ActiveSheet.Name = "ANALİZ_" & X With ActiveSheet.QueryTables.Add(Connection:="URL;" & URL_LİNK, Destination:=Range("A" & sat)) 'Set S2 = Sheets("KURLAR") Destination:=S2.[A1]) .Name = "ANALİZ_" & X .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 Sheets("Sayfa1").Select Application.ScreenUpdating = True 'MsgBox "İşleminiz tamamlanmıştır.", vbInformation Range("A1").Select End Sub http://www.excel.web.tr/archive/index.php/f-48-p-10.html Not: sayfalar excele manuel kopyala yapıştır yaptığımızda linkleri ile birlikte geliyor, kodlarla çektiğimiz de de aynı şekilde olması gerekli. Yukarıda verdiğim linkde Sn. Zeki Beyin kodları da mevcut ancak denemede başarılı olamadım. İlgilenecek arkadaşlarıma şimdiden teşekkür ederim.
__________________
Kolay Gelsin Tahsin. |
![]() |
![]() |
![]() |
#2 |
Altın Üye
Giriş: 04/06/2005
Şehir: K.Maraş
Mesaj: 2,092
Excel Vers. ve Dili:
2010-2016 |
![]() Aşağıdaki şekilde deneyin.
Sub ASKM_excel_web_tr() Dim ie As Object, i%, a% Dim Yazi As String Dim sat Set ie = CreateObject("internetexplorer.application") With ie Cells.ClearContents Sheets("Sayfa2").Range("A1").Value = " KONULAR " For i = 1 To 192 adres = "http://www.excel.web.tr/archive/index.php/f-48-p-" & i & ".html" .navigate adres .Visible = True On Error GoTo Hata Do Until .readyState = 4: DoEvents: Loop Do While .Busy: DoEvents: Loop For y = 0 To 249 sat = Sheets("Sayfa2").Range("A65536").End(3).Row + 1 Yazi = .document.getElementById("content").getElementsByTagName("a")(y).innerText Sheets("Sayfa2").Range("A" & sat).Value = StrConv(Yazi, vbProperCase) ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sayfa2").Range("A" & sat), Address:= _ adres, TextToDisplay:=StrConv(Yazi, vbProperCase) Next y Next i Hata: .Quit End With Set ie = Nothing: i = Empty: a = Empty MsgBox "İşlem tamamlandı...", vbInformation, "ASKM" End Sub
__________________
excel 2010- türkçe |
![]() |
![]() |
![]() |
#3 |
Altın Üye
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,781
Excel Vers. ve Dili:
Ofis 2016 Türkçe |
![]() Slm askm Bey, öncelikle verdiğiniz cevap için çok teşekkür ederim, kodları şimdi denedim, güzel çalışıyor ancak 26. sayfada işlem tamamlandı diyor.(6287 satır) Yani 192 sayfaya kadar devem etmedi. iki kez denedim. Bakabilirseniz 47166 satır ben manüel olarak çekmiştim.
__________________
Kolay Gelsin Tahsin. |
![]() |
![]() |
![]() |
#4 |
Altın Üye
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,781
Excel Vers. ve Dili:
Ofis 2016 Türkçe |
![]() Sn.askm Bey
On Error GoTo Hata ile ilgili satırları kaldırıp On Error Resume Next yaptım, şu an 106. sayfaya kadar geldi, ama arada sayfa atlarmı bilmiyorum. Bitirsin bakayım.
__________________
Kolay Gelsin Tahsin. |
![]() |
![]() |
![]() |
#5 |
Altın Üye
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,781
Excel Vers. ve Dili:
Ofis 2016 Türkçe |
![]() Sn. askm Bey, indirme işlemi tamamlandı, ancak satıra tıkladığımda indirdiğimiz sayfa linkine gidiyor, ben istiyorum ki aynen manüel olarak yapıştırıp satıra tıkladığımda ilgili konunun bulunduğu sayfaya gittiği gibi olsun, bu şekilde olabilirse çok güzel olacak. Teşekkürler.
__________________
Kolay Gelsin Tahsin. |
![]() |
![]() |
![]() |
#6 |
Altın Üye
Giriş: 04/06/2005
Şehir: K.Maraş
Mesaj: 2,092
Excel Vers. ve Dili:
2010-2016 |
![]() on error hata kısmını örneğin siz döngüyü 250 yaparsınız 192 sayfa var 193. sayfayık bulamayacağı için hata verirse diye düşünmüştüm.
Aşağıdaki gibi deneyin. Sub ASKM_excel_web_tr() Dim ie As Object, i%, a% Dim Yazi As String Dim sat Dim link Set ie = CreateObject("internetexplorer.application") With ie Cells.ClearContents Sheets("Sayfa2").Range("A1").Value = " KONULAR " For i = 1 To 192 adres = "http://www.excel.web.tr/archive/index.php/f-48-p-" & i & ".html" .navigate adres .Visible = True On Error Resume Next Do Until .readyState = 4: DoEvents: Loop Do While .Busy: DoEvents: Loop For y = 0 To 249 sat = Sheets("Sayfa2").Range("A65536").End(3).Row + 1 link = .document.getElementById("content").getElementsByTagName("a")(y).href Yazi = .document.getElementById("content").getElementsByTagName("a")(y).innerText Sheets("Sayfa2").Range("A" & sat).Value = StrConv(Yazi, vbProperCase) ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sayfa2").Range("A" & sat), Address:= _ link, TextToDisplay:=StrConv(Yazi, vbProperCase) Next y Next i Hata: .Quit End With Set ie = Nothing: i = Empty: a = Empty MsgBox "İşlem tamamlandı...", vbInformation, "ASKM" End Sub
__________________
excel 2010- türkçe |
![]() |
![]() |
![]() |
#7 |
Altın Üye
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,781
Excel Vers. ve Dili:
Ofis 2016 Türkçe |
![]() Sn. askm kardeşim eline koluna sağlık tam istediğim gibi oldu, çok teşekkür ederim.
__________________
Kolay Gelsin Tahsin. |
![]() |
![]() |
![]() |
#8 |
Altın Üye
Giriş: 04/06/2005
Şehir: K.Maraş
Mesaj: 2,092
Excel Vers. ve Dili:
2010-2016 |
![]() Kolay gelsin.
__________________
excel 2010- türkçe |
![]() |
![]() |