Soru https://www.imdb.com/ sitesinden veri alma

Sub Web_XmlHttp()
    'Not: Excel > VBA > Tools > References > MicrosoftHTML Object Library ve Microsoft XML, v6.0 işaretlemeniz gerekmektedir.
    Dim xmlHTTPReq As Object
    Dim htmldoc As HTMLDocument
    Dim postURL As String
    Set xmlHTTPReq = CreateObject("MSXML2.XMLHTTP")
    Set htmldoc = New HTMLDocument
    For a = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        postURL = "https://www.imdb.com/title/" & Cells(a, 1) & "/"     
        With xmlHTTPReq
            .Open "GET", postURL, False
            .Send
        End With     

        If xmlHTTPReq.Status = 200 Then
            htmldoc.body.innerHTML = xmlHTTPReq.responseText
            On Error Resume Next
            adi = htmldoc.querySelector("h1").innerText
            Debug.Print "Film Adı: " & adi
            On Error GoTo 0   
            If Not IsEmpty(adi) Then
                Cells(a, 2) = Left(adi, Len(adi) - 8)
                Cells(a, 4) = Replace(Right(adi, 6), ")", "")
            Else
                Cells(a, 2) = "Bulunamadı"
                Cells(a, 4) = "Bulunamadı"
            End If

            On Error Resume Next
            ratin = htmldoc.querySelector(".ratingValue span").innerText
            Debug.Print "Rating: " & ratin
            On Error GoTo 0
            If Not IsEmpty(ratin) Then
                Cells(a, 5) = Left(ratin, Len(ratin) - 4)
            Else
                Cells(a, 5) = "Bulunamadı"
            End If
            On Error Resume Next
            Cells(a, 6) = htmldoc.querySelector(".ipc-inline-list__item").innerText
            Debug.Print "Süre: " & htmldoc.querySelector(".ipc-inline-list__item").innerText
            On Error GoTo 0
            On Error Resume Next
            Set direct = htmldoc.querySelector(".credit_summary_item")

            If Not direct Is Nothing Then
                Cells(a, 7) = direct.querySelector("a").innerText
                Debug.Print "Yönetmen: " & direct.querySelector("a").innerText
            Else
                Cells(a, 7) = "Bulunamadı"
            End If
            On Error GoTo 0
        Else
            Debug.Print "HTTP Request Failed. Status: " & xmlHTTPReq.Status & " - " & xmlHTTPReq.statusText
        End If
    Next a
    Set htmldoc = Nothing
    Set xmlHTTPReq = Nothing
    MsgBox "İşlem tamam", vbInformation + vbMsgBoxRtlReading, "Tamamlandı - Excelçözüm"
End Sub

Sub IMDB()
    Dim http As Object
    Dim html As Object
    Dim movieName As String
    Dim searchURL As String
    Dim ws As Worksheet
    Dim movieTitle As String, releaseYear As String, actors As String
    Dim resultDivs As Object
    Dim i As Integer
    
    ' Çalışma sayfası seçimi
    Set ws = ThisWorkbook.Sheets(1)
    
    ' Kullanıcıdan film adı alma
    movieName = ws.Range("A2").Value ' A2 hücresine film adını girin.
    If movieName = "" Then
        MsgBox "Film adı boş bırakılamaz!", vbExclamation
        Exit Sub
    End If
    
    ' Türkçe karakterleri temizle
    movieName = TrKrktrSil(movieName)
    
    ' IMDb arama bağlantısı
    searchURL = "https://www.imdb.com/find/?s=tt&q=" & URLEncode(movieName) & "&ref_=nv_sr_sm"
    
    ' HTTP isteği gönderme
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", searchURL, False
    http.send
    
    ' HTML içeriğini al
    Set html = CreateObject("HTMLFile")
    html.body.innerHTML = http.responseText
    
    ' Arama sonuçlarını bulma
    On Error Resume Next
    Set resultDivs = html.querySelectorAll("div.ipc-metadata-list-summary-item__c")
    
      ' Çalışma sayfasını temizle
    ws.Range("B3:D" & ws.Rows.Count).ClearContents
    
    ' Çalışma sayfasına başlıkları yazdırma
    ws.Range("B2").Value = "Film Adı"
    ws.Range("C2").Value = "Yapım Yılı"
    ws.Range("D2").Value = "Oyuncular"
    
    ' Birden fazla sonucu döndürme
    If resultDivs.Length > 0 Then
        For i = 0 To resultDivs.Length - 1
            ' Her sonucun başlığını, yılı ve oyuncuları alalım
            movieTitle = resultDivs.Item(i).querySelector("a.ipc-metadata-list-summary-item__t").innerText
            releaseYear = resultDivs.Item(i).querySelector("ul.ipc-inline-list > li > span").innerText
            actors = resultDivs.Item(i).querySelector("ul.ipc-inline-list--no-wrap.ipc-inline-list--inline.ipc-metadata-list-summary-item__stl > li > span").innerText
            
            ' Çalışma sayfasına yazdırma
            ws.Cells(i + 3, 2).Value = movieTitle
            ws.Cells(i + 3, 3).Value = releaseYear
            ws.Cells(i + 3, 4).Value = actors
        Next i
    Else
        MsgBox "Film bulunamadı!", vbExclamation
    End If
    
    MsgBox "Film bilgileri başarıyla alındı!", vbInformation
End Sub

Function TrKrktrSil(ByVal Text As String) As String
    Dim result As String
    result = Text
    result = Replace(result, "ç", "c")
    result = Replace(result, "Ç", "C")
    result = Replace(result, "ğ", "g")
    result = Replace(result, "Ğ", "G")
    result = Replace(result, "ı", "i")
    result = Replace(result, "İ", "I")
    result = Replace(result, "ö", "o")
    result = Replace(result, "Ö", "O")
    result = Replace(result, "ş", "s")
    result = Replace(result, "Ş", "S")
    result = Replace(result, "ü", "u")
    result = Replace(result, "Ü", "U")
    TrKrktrSil = result
End Function

Function URLEncode(ByVal Text As String) As String
    Dim i As Long
    Dim Char As String
    Dim result As String
    
    For i = 1 To Len(Text)
        Char = Mid(Text, i, 1)
        Select Case Asc(Char)
            Case 48 To 57, 65 To 90, 97 To 122 ' Alphanumeric characters
                result = result & Char
            Case Else
                result = result & "%" & Right("0" & Hex(Asc(Char)), 2)
        End Select
    Next i
    
    URLEncode = result
End Function

Sub SinemalarVeriCek()
    Dim http As Object, html As Object
    Dim movieResults As Object, movie As Object
    Dim ws As Worksheet
    Dim url As String, searchQuery As String
    Dim i As Long
    Dim posterUrl As String
    Dim img As Picture
    Dim sheetName As String
    
    ' "Arama" sayfasında A2 hücresinden arama terimini al
    On Error Resume Next
    searchQuery = Trim(ThisWorkbook.Sheets("Arama").Range("A2").Value)
    On Error GoTo 0
    
    ' Eğer A2 hücresi boşsa hata ver
    If searchQuery = "" Then
        MsgBox "Lütfen 'Arama' sayfasında A2 hücresine bir arama sorgusu girin!", vbExclamation
        Exit Sub
    End If
    
    ' Türkçe karakterleri İngilizce karşılıklarına dönüştür
    searchQuery = Replace(searchQuery, "Ç", "C")
    searchQuery = Replace(searchQuery, "Ğ", "G")
    searchQuery = Replace(searchQuery, "İ", "I")
    searchQuery = Replace(searchQuery, "Ö", "O")
    searchQuery = Replace(searchQuery, "Ş", "S")
    searchQuery = Replace(searchQuery, "Ü", "U")
    searchQuery = Replace(searchQuery, "ç", "c")
    searchQuery = Replace(searchQuery, "ğ", "g")
    searchQuery = Replace(searchQuery, "ı", "i")
    searchQuery = Replace(searchQuery, "ö", "o")
    searchQuery = Replace(searchQuery, "ş", "s")
    searchQuery = Replace(searchQuery, "ü", "u")
    
    ' Geçersiz karakterleri temizle ve sayfa adını oluştur
    sheetName = Replace(searchQuery, "/", "_")
    sheetName = Replace(sheetName, "\", "_")
    sheetName = Replace(sheetName, ":", "_")
    sheetName = Replace(sheetName, "*", "_")
    sheetName = Replace(sheetName, "?", "_")
    sheetName = Replace(sheetName, "[", "_")
    sheetName = Replace(sheetName, "]", "_")
    
    ' Sayfa adının 31 karakterden uzun olmamasını sağla
    If Len(sheetName) > 31 Then sheetName = Left(sheetName, 31)
    
    ' Aynı isimde bir sayfa varsa, uyarı ver
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    If Not ws Is Nothing Then
        MsgBox "Aynı isimde bir sayfa zaten mevcut. İşleme devam edilemez.", vbExclamation
        Exit Sub
    End If
    
    ' Yeni bir çalışma sayfası oluştur
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = sheetName
    ws.Cells(1, 2).Value = "Film Adı"
    ws.Cells(1, 3).Value = "Orijinal Adı"
    ws.Cells(1, 4).Value = "Tür"
    ws.Cells(1, 5).Value = "Bilgi"
    ws.Cells(1, 6).Value = "Bağlantı"
    ws.Cells(1, 7).Value = "Oyuncular"
    ws.Cells(1, 8).Value = "Afiş"
    
    ' URL oluştur
    url = "https://www.sinemalar.com/ara/?type=movies&q=" & Replace(searchQuery, " ", "%20")
    
    ' HTTP ve HTML nesneleri
    Set http = CreateObject("MSXML2.XMLHTTP")
    Set html = CreateObject("HTMLFILE")
    
    ' Web sayfasını al
    http.Open "GET", url, False
    http.send
    html.body.innerHTML = http.responseText
    
    ' Filmleri seç
    Set movieResults = html.getElementsByClassName("movie")
    
    For i = 0 To movieResults.Length - 1
        Set movie = movieResults.Item(i)
        With ws
            ' Film bilgilerini çıkar
            .Cells(i + 2, 2).Value = movie.getElementsByClassName("name")(0).innerText ' Film Adı
            .Cells(i + 2, 3).Value = movie.getElementsByClassName("org-name")(0).innerText ' Orijinal Adı
            .Cells(i + 2, 4).Value = movie.getElementsByClassName("genre")(0).innerText ' Tür
            .Cells(i + 2, 5).Value = movie.getElementsByClassName("item")(0).getElementsByClassName("text")(0).innerText ' Bilgi
            .Cells(i + 2, 6).Value = movie.href ' Bağlantı
            
            ' Oyuncu bilgilerini çıkar
            On Error Resume Next
            Dim actors As Object
            Dim actorNames As String
            Set actors = movie.getElementsByClassName("side-info")(1).getElementsByTagName("span")
            If Not actors Is Nothing Then
                actorNames = ""
                For Each actor In actors
                    actorNames = actorNames & actor.innerText & ", "
                Next actor
                actorNames = Left(actorNames, Len(actorNames) - 2) ' Son virgülü kaldır
                .Cells(i + 2, 7).Value = actorNames ' Oyuncular
            Else
                .Cells(i + 2, 7).Value = "Oyuncu bilgisi yok"
            End If
            On Error GoTo 0
            
            ' Afiş URL'sini al
            On Error Resume Next
            posterUrl = movie.getElementsByClassName("movie-poster")(0).getElementsByTagName("img")(0).getAttribute("src")
            If posterUrl <> "" Then
                ' Afişi hücreye görsel olarak ekle
                Set img = ws.Pictures.Insert(posterUrl)
                With img
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = ws.Cells(i + 2, 8).Left
                    .Top = ws.Cells(i + 2, 8).Top
                    .Width = 100 ' Resmin genişliği
                    .Height = 150 ' Resmin yüksekliği
                End With
            Else
                .Cells(i + 2, 8).Value = "Afiş yok"
            End If
            On Error GoTo 0
        End With
    Next i
    
    ' Hücreleri AutoFit ile düzenle
    ws.Columns("B:H").AutoFit
    
    ' Başarı mesajı
    MsgBox "Veriler '" & sheetName & "' sayfasına başarıyla çekildi ve hücreler düzenlendi!", vbInformation
End Sub

Sub FilmleriCek()
    Dim xhr As Object
    Dim html As Object
    Dim filmElements As Object
    Dim film As Object
    Dim row As Long
    Dim ws As Worksheet
  
    ' Excel sayfasını ayarla
    Set ws = ThisWorkbook.ActiveSheet
    ws.Cells.Clear
  
    ' Sayfa arka plan rengini ayarla
    ws.Cells.Interior.Color = RGB(245, 245, 245)
  
    ' Başlıkları ekle
    ws.Cells(1, 1) = "Film Adı"
    ws.Cells(1, 2) = "Poster"
    ws.Cells(1, 3) = "IMDB"
    ws.Cells(1, 4) = "Yıl"
  
    ' Başlıkları formatla
    With ws.Range("A1:D1")
        .Font.Bold = True
        .Font.Size = 12
        .Font.Name = "Calibri"
        .Interior.Color = RGB(51, 51, 51)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 30
    End With
  
    ' Sütun genişliklerini ayarla
    ws.Columns("A").ColumnWidth = 40
    ws.Columns("B").ColumnWidth = 12
    ws.Columns("C").ColumnWidth = 10
    ws.Columns("D").ColumnWidth = 10
  
    ' XMLHTTP nesnesi oluştur
    Set xhr = CreateObject("MSXML2.XMLHTTP")
  
    ' Web sitesine istek gönder
    With xhr
        .Open "GET", "https://www.hdfilmcehennemi.nl/", False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
    End With
  
    ' HTML parser oluştur
    Set html = CreateObject("htmlfile")
    html.body.innerHTML = xhr.responseText
  
    ' Film elementlerini seç
    Set filmElements = html.getElementsByClassName("poster")
  
    ' Başlangıç satırı
    row = 2
  
    ' Her film için döngü
    For Each film In filmElements
        Dim filmAdi As String
        Dim posterURL As String
        Dim imdbPuan As String
        Dim filmYil As String
      
        ' Film adını al
        On Error Resume Next
        filmAdi = film.getAttribute("title")
      
        ' Poster URL'sini al
        Dim imgElement As Object
        Set imgElement = film.getElementsByTagName("img")(0)
        If Not imgElement Is Nothing Then
            posterURL = imgElement.getAttribute("data-src")
            If posterURL = "" Then
                posterURL = imgElement.getAttribute("src")
            End If
        End If
      
        ' IMDB puanını al
        Dim imdbSpan As Object
        Set imdbSpan = film.getElementsByClassName("imdb")(0)
        If Not imdbSpan Is Nothing Then
            imdbPuan = Replace(imdbSpan.innerText, "IMDB:", "")
        End If
      
        ' Yılı al
        Dim metaDiv As Object
        Set metaDiv = film.getElementsByClassName("poster-meta")(0)
        If Not metaDiv Is Nothing Then
            For Each span In metaDiv.getElementsByTagName("span")
                If IsNumeric(span.innerText) Then
                    filmYil = span.innerText
                    Exit For
                End If
            Next span
        End If
      
        ' Verileri Excel'e yaz
        If filmAdi <> "" Then
            ' Film adını yaz ve formatla
            With ws.Cells(row, 1)
                .Value = filmAdi
                .Font.Name = "Calibri"
                .Font.Size = 11
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(255, 255, 255)
            End With
          
            ' IMDB puanını yaz
            With ws.Cells(row, 3)
                .Value = imdbPuan
                .Font.Name = "Calibri"
                .Font.Size = 11
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(255, 255, 255)
            End With
          
            ' Yılı yaz
            With ws.Cells(row, 4)
                .Value = filmYil
                .Font.Name = "Calibri"
                .Font.Size = 11
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(255, 255, 255)
            End With
          
            ' Poster resmini ekle
            If posterURL <> "" Then
                On Error Resume Next
                With ws.Shapes.AddPicture( _
                    DownloadImage(posterURL), _
                    False, True, _
                    ws.Cells(row, 2).Left + 5, _
                    ws.Cells(row, 2).Top + 5, _
                    80, 100)
                End With
                On Error GoTo 0
            End If
          
            ' Satır yüksekliğini ayarla
            ws.Rows(row).RowHeight = 80
          
            ' Hücre çerçevelerini ayarla
            ws.Range(ws.Cells(row, 1), ws.Cells(row, 4)).Borders.LineStyle = xlContinuous
            ws.Range(ws.Cells(row, 1), ws.Cells(row, 4)).Borders.Color = RGB(200, 200, 200)
          
            row = row + 1
        End If
    Next film
  
    ' Alternatif satır renklendirmesi
    For i = 2 To row - 1 Step 2
        ws.Range(ws.Cells(i, 1), ws.Cells(i, 4)).Interior.Color = RGB(250, 250, 250)
    Next i
  
    MsgBox "Film verileri başarıyla çekildi!", vbInformation
End Sub

Private Function DownloadImage(ByVal imageUrl As String) As String
    ' Resmi geçici klasöre indir
    Dim tempPath As String
    tempPath = Environ$("TEMP") & "\" & CreateGuid() & ".jpg"
  
    Dim xhr As Object
    Set xhr = CreateObject("MSXML2.XMLHTTP")
  
    With xhr
        .Open "GET", imageUrl, False
        .send
    End With
  
    If xhr.Status = 200 Then
        Dim stream As Object
        Set stream = CreateObject("ADODB.Stream")
      
        With stream
            .Type = 1 'Binary
            .Open
            .Write xhr.responseBody
            .SaveToFile tempPath, 2 'Overwrite
            .Close
        End With
    End If
  
    DownloadImage = tempPath
End Function

Private Function CreateGuid() As String
    CreateGuid = Format(Now, "yyyymmddhhnnss") & "-" & Int(Rnd * 1000000)
End Function