Güncel Market Fiyatları İnternetten Bulmak

H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
beab05' Alıntı:
Ben resimleri istersiniz diye bekliyordum :)
Genişletmek için tıkla ...
Neyseki VBA ile parçaları birleştirip, araba yapılması istenmedi :)

Şaka bir yana, 70 adet ürün için sunucuya 70 defa istek gönderip geri dönen sonucu ayıklamak gerekir. Hem Excel'e yazık olur, hem de bana.....

.
 
S

serkagkx

Katılım
9 Mart 2023
Mesajlar
11
Excel Vers. ve Dili
v6
Haluk' Alıntı:
Neyseki VBA ile parçaları birleştirip, araba yapılması istenmedi :)

Şaka bir yana, 70 adet ürün için sunucuya 70 defa istek gönderip geri dönen sonucu ayıklamak gerekir. Hem Excel'e yazık olur, hem de bana.....

.
Genişletmek için tıkla ...
valla hocam uğraştırıyoruz senide ama 1 haftadan fazladır çözüm arıyorum ya 10 dk da çözdük neredeyse
 
beab05

beab05

Özel Üye
Katılım
19 Mart 2007
Mesajlar
1,420
Excel Vers. ve Dili
Office 2013
Zaten tüm sayfalar içindeki ürünleri tek seferde almak doğru olmaz. Bunun bir sürü dezavantajı var. Bu sebeple önce sayfalar listelenmeli ve sonra seçilen sayfaya göre kullanıcı istek yapmalı. Ya da ilk sayfa verileri alınır ve diğer sayfa numaraları da da uygun bir yere yazdırılır combobox gibi ve seçilip sorgulanır.

Ya da kullanıcı sayfaları ve linki bir hücreye manuel girsin ve ve öyle aratsın. Bir hücreye linki bir hücreye sayfa numarasını..
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Ürün açıklamalarına alternatif olarak; A sütunundaki ürün isimlerine link eklenir, kullanıcı tıkladığında o ürüne ait açıklamaların olduğu web sayfasına gider.


Capture.PNG



Bu işinize yararsa, ilgili kod;

C#: 
Sub Test6()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:B" & Rows.Count).ClearContents
Range("A1:B1") = Array("Ürün", "Fiyat")

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
        End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
.
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Başka bir alternatif de; A sütunundaki ürün isimlerine link ekledikten sonra, C sütununa otomatik olarak yerleştirilen "Detay" butonlarına tıklandığında D sütunundaki hücreye ürünün açıklamasını getirmektir.

Böylece, sadece istenen ürünlerin açıklamaları alınmış olur ve Excel fazla yorulmaz....


Capture.PNG



Bununla ilgili kodlar;

C#: 
Sub Test7()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:C" & Rows.Count).ClearContents
Range("A1:C1") = Array("Ürün", "Fiyat", "Detay")

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
     
            Set btn = ActiveSheet.Buttons.Add(Range("C" & iRow + 1).Left, Range("C" & iRow + 1).Top, Range("C" & iRow + 1).Width, Range("C" & iRow + 1).Height)
            With btn
              .OnAction = "getDetails"
              .Caption = "Detay"
              .Name = "Btn" & iRow
            End With
       End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
'
Sub getDetails()
    i = Replace(Application.Caller, "Btn", "")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
   
    Set HTML = CreateObject("HTMLFILE")
   
    strURL = Range("A" & i + 1).Hyperlinks(1).Address
   
    objHTTP.Open "GET", strURL, False
    objHTTP.send
   
    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")
   
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-detail" Then
            On Error Resume Next
            Range("D" & i + 1) = Trim(Divs(x).getElementsByTagName("span")(0).innerText)
            On Error GoTo 0
        End If
    Next
End Sub
.
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Ürün resimleriyle ilgili olarak da; istenilen ürüne ait "Detay" butonuna tıklandığında D sütunundaki hücreye ürüne ait açıklamayla birlikte, o hücreye "Comment-Açıklama" eklenir ve hücrenin üzerine mouse ile gelindiğinde "Açıklamanın" içerisinde ürünün resmi görüntülenir.


Untitled.png

Bununla ilgili kodlar da;

C#: 
Sub Test8()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:D" & Rows.Count).ClearContents
Range("D1:D" & Rows.Count).ClearComments
ActiveSheet.Buttons.Delete
Range("A1:D1") = Array("Ürün", "Fiyat", "", "Detay")
Range("A1:D1").Font.Bold = True
Columns("A").ColumnWidth = 50
Columns("B:D").ColumnWidth = 9

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
       
            Set btn = ActiveSheet.Buttons.Add(Range("C" & iRow + 1).Left, Range("C" & iRow + 1).Top, Range("C" & iRow + 1).Width, Range("C" & iRow + 1).Height)
            With btn
              .OnAction = "getDetails"
              .Caption = "Detay"
              .Name = "Btn" & iRow
            End With
       End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
'
Private Sub getDetails()
    i = Replace(Application.Caller, "Btn", "")
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    
    Set HTML = CreateObject("HTMLFILE")
    
    strURL = Range("A" & i + 1).Hyperlinks(1).Address
    
    objHTTP.Open "GET", strURL, False
    objHTTP.send
    
    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")
    
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-detail" Then
            On Error Resume Next
            Range("D" & i + 1) = Trim(Divs(x).innerText)
            Range("D" & i + 1) = Trim(Divs(x).getElementsByTagName("span")(0).innerText)
            Range("D" & i + 1).WrapText = False
            On Error GoTo 0
        End If
        
        If Divs(x).ID = "product-primary-image" Then
            On Error Resume Next
            Set CommentBox = Range("D" & i + 1).AddComment
            picURL = Replace(Divs(x).getElementsByTagName("img")(0).src, "about:", "https:")
            CommentBox.Shape.Fill.UserPicture (picURL)
            CommentBox.Shape.Width = 100
            CommentBox.Shape.Height = 100
            On Error GoTo 0
        End If
    Next
End Sub
.
 
Son düzenleme:
T

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,820
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Sayın Haluk Hocam,
Muhteşemsiniz, insanda daha neler yapılabilir? sorusunun canlanmasını tetikliyorsunuz. Excel'de ve GoogleDrive tabanlı işlemlerde sizden de çok şey öğrendiğimi biliyorum ve müteşekkirim. Gerçi henüz, destek olmadan internet tabanlı işlemlerde başarılı olamıyorum ama olsun hep destekleyen excel.web.tr ailesinin yanımda olduğunu biliyorum.
akakce.com da kategorileri listelemek istedim ama başarılı olamadım. Daha nerelere dikkat etmem gerektiğini tam kavrayamamışım demek, ama, öğreneceğim!
Saygılarımla
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Tevfik Bey, nazik mesajınız için size ve mesajlarda "Beğenisini" ileten herkese teşekkür ederim...

.
 
T

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,820
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Rica ederim
Saygılarımla
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
serkagkx' Alıntı:
valla hocam uğraştırıyoruz senide ama 1 haftadan fazladır çözüm arıyorum ya 10 dk da çözdük neredeyse
Genişletmek için tıkla ...
İcimde kalmasin diye yaziyorum........Biz ugrastik ortaya birseyler cikarttik, ama siz zahmet edip bir cevap bile yazmadiniz.

.
 
Son düzenleme:
ibere

ibere

Altın Üye
Katılım
31 Mart 2018
Mesajlar
129
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
21-04-2027
Haluk' Alıntı:
Ürün resimleriyle ilgili olarak da; istenilen ürüne ait "Detay" butonuna tıklandığında D sütunundaki hücreye ürüne ait açıklamayla birlikte, o hücreye "Comment-Açıklama" eklenir ve hücrenin üzerine mouse ile gelindiğinde "Açıklamanın" içerisinde ürünün resmi görüntülenir.


Ekli dosyayı görüntüle 243502

Bununla ilgili kodlar da;

C#: 
Sub Test8()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:D" & Rows.Count).ClearContents
Range("D1:D" & Rows.Count).ClearComments
ActiveSheet.Buttons.Delete
Range("A1:D1") = Array("Ürün", "Fiyat", "", "Detay")
Range("A1:D1").Font.Bold = True
Columns("A").ColumnWidth = 50
Columns("B:D").ColumnWidth = 9

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
      
            Set btn = ActiveSheet.Buttons.Add(Range("C" & iRow + 1).Left, Range("C" & iRow + 1).Top, Range("C" & iRow + 1).Width, Range("C" & iRow + 1).Height)
            With btn
              .OnAction = "getDetails"
              .Caption = "Detay"
              .Name = "Btn" & iRow
            End With
       End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
'
Private Sub getDetails()
    i = Replace(Application.Caller, "Btn", "")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
   
    Set HTML = CreateObject("HTMLFILE")
   
    strURL = Range("A" & i + 1).Hyperlinks(1).Address
   
    objHTTP.Open "GET", strURL, False
    objHTTP.send
   
    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")
   
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-detail" Then
            On Error Resume Next
            Range("D" & i + 1) = Trim(Divs(x).innerText)
            Range("D" & i + 1) = Trim(Divs(x).getElementsByTagName("span")(0).innerText)
            Range("D" & i + 1).WrapText = False
            On Error GoTo 0
        End If
       
        If Divs(x).ID = "product-primary-image" Then
            On Error Resume Next
            Set CommentBox = Range("D" & i + 1).AddComment
            picURL = Replace(Divs(x).getElementsByTagName("img")(0).src, "about:", "https:")
            CommentBox.Shape.Fill.UserPicture (picURL)
            CommentBox.Shape.Width = 100
            CommentBox.Shape.Height = 100
            On Error GoTo 0
        End If
    Next
End Sub
.
Genişletmek için tıkla ...
Hocam eline sağlık, şu xmlhttp nesnesini öğrenmek istiyorum fakat detaylı bir rehber bulamadım. Yardımcı olursan sevinirim.
 
E

emsey

Katılım
18 Mart 2007
Mesajlar
171
Excel Vers. ve Dili
OFFICE 2016
Altın Üyelik Bitiş Tarihi
02-03-2024
Haluk' Alıntı:
Ürün resimleriyle ilgili olarak da; istenilen ürüne ait "Detay" butonuna tıklandığında D sütunundaki hücreye ürüne ait açıklamayla birlikte, o hücreye "Comment-Açıklama" eklenir ve hücrenin üzerine mouse ile gelindiğinde "Açıklamanın" içerisinde ürünün resmi görüntülenir.


Ekli dosyayı görüntüle 243502

Bununla ilgili kodlar da;

C#: 
Sub Test8()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:D" & Rows.Count).ClearContents
Range("D1:D" & Rows.Count).ClearComments
ActiveSheet.Buttons.Delete
Range("A1:D1") = Array("Ürün", "Fiyat", "", "Detay")
Range("A1:D1").Font.Bold = True
Columns("A").ColumnWidth = 50
Columns("B:D").ColumnWidth = 9

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
      
            Set btn = ActiveSheet.Buttons.Add(Range("C" & iRow + 1).Left, Range("C" & iRow + 1).Top, Range("C" & iRow + 1).Width, Range("C" & iRow + 1).Height)
            With btn
              .OnAction = "getDetails"
              .Caption = "Detay"
              .Name = "Btn" & iRow
            End With
       End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
'
Private Sub getDetails()
    i = Replace(Application.Caller, "Btn", "")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
   
    Set HTML = CreateObject("HTMLFILE")
   
    strURL = Range("A" & i + 1).Hyperlinks(1).Address
   
    objHTTP.Open "GET", strURL, False
    objHTTP.send
   
    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")
   
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-detail" Then
            On Error Resume Next
            Range("D" & i + 1) = Trim(Divs(x).innerText)
            Range("D" & i + 1) = Trim(Divs(x).getElementsByTagName("span")(0).innerText)
            Range("D" & i + 1).WrapText = False
            On Error GoTo 0
        End If
       
        If Divs(x).ID = "product-primary-image" Then
            On Error Resume Next
            Set CommentBox = Range("D" & i + 1).AddComment
            picURL = Replace(Divs(x).getElementsByTagName("img")(0).src, "about:", "https:")
            CommentBox.Shape.Fill.UserPicture (picURL)
            CommentBox.Shape.Width = 100
            CommentBox.Shape.Height = 100
            On Error GoTo 0
        End If
    Next
End Sub
.
Genişletmek için tıkla ...
Vay arkadaş maşallah ya. Kod anlatılmaz yazılır olduğunu defalarca öğrenmiş olduk. Emeğine yüreğine sağlık üstad.
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
S

serkagkx

Katılım
9 Mart 2023
Mesajlar
11
Excel Vers. ve Dili
v6
Hocam tekrardan Merhaba yardımınız için teşekkür ederim, detay butonuna tıklamadan olduğu gibi açıklamalarıda getirebilir miyiz?
Haluk' Alıntı:
Başka bir alternatif de; A sütunundaki ürün isimlerine link ekledikten sonra, C sütununa otomatik olarak yerleştirilen "Detay" butonlarına tıklandığında D sütunundaki hücreye ürünün açıklamasını getirmektir.

Böylece, sadece istenen ürünlerin açıklamaları alınmış olur ve Excel fazla yorulmaz....


Ekli dosyayı görüntüle 243501



Bununla ilgili kodlar;

C#: 
Sub Test7()
' Haluk - 09/03/2023

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer

Range("A1:C" & Rows.Count).ClearContents
Range("A1:C1") = Array("Ürün", "Fiyat", "Detay")

Set objHTTP = CreateObject("MSXML2.XMLHTTP")

Set HTML = CreateObject("HTMLFILE")

strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca"

objHTTP.Open "GET", strURL, False
objHTTP.send

HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
    If Divs(x).classname = ("record-count text-right mt-3 mb-3") Then
        iCount = Split(Divs(x).innerText, " ")(1) \ 30 + 1
    End If
Next

For j = 1 To iCount
    strURL = "https://www.onlineyedekparca.com/kategori/opel-tigra-a-yedek-parca?tp=" & j

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "showcase-title" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & iRow + 1), Address:="https://www.onlineyedekparca.com/" & Replace(Divs(x).getElementsByTagName("a")(0).href, "about:/", "")
    
            Set btn = ActiveSheet.Buttons.Add(Range("C" & iRow + 1).Left, Range("C" & iRow + 1).Top, Range("C" & iRow + 1).Width, Range("C" & iRow + 1).Height)
            With btn
              .OnAction = "getDetails"
              .Caption = "Detay"
              .Name = "Btn" & iRow
            End With
       End If
        If Divs(x).classname = "showcase-price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
Next
End Sub
'
Sub getDetails()
    i = Replace(Application.Caller, "Btn", "")
  
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  
    Set HTML = CreateObject("HTMLFILE")
  
    strURL = Range("A" & i + 1).Hyperlinks(1).Address
  
    objHTTP.Open "GET", strURL, False
    objHTTP.send
  
    HTML.body.innerHTML = objHTTP.responseText

    Set Divs = HTML.getElementsByTagName("div")
  
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-detail" Then
            On Error Resume Next
            Range("D" & i + 1) = Trim(Divs(x).getElementsByTagName("span")(0).innerText)
            On Error GoTo 0
        End If
    Next
End Sub
.
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst