[심화방] VBA_심화_100제 #19 [ 유튜브목록 가져오기]

이번에는 유튜브 댓글에 이어 유튜브 목록을 가져오는 코드를 진행해보려고 한다.

본인같은 경우 유튜브에서 강의를 볼 경우 한 사람의 강의를 끝까지 보는 스타일이다.

 

이유는 그래야 코드를 따라치면서 유튜브상의 쌤들의 스타일을 알게되어 코드를 이해하는데도 더 편하기 때문이다.

본인이 공부할때 엑사남님의 스타일을 배워가면서 점점 본인의 스타일을 완성하였기 때문에  이글을 읽는 분들도 한번 따라해보시길 바란다.

https://www.youtube.com/@excelloveman-3399/videos

엑사남ExcelLoveMan-

맘잡고 공부하려고 해도 다시 찾아보기가 힘들어서 목록을 가져오는 코드를 작성하였으니 함께 공부하길 바란다.

 

코드 진행은 이렇다.

1. 스크롤을 끝까지 내린다.

2. 부모 태그를 설정한다.

3. 로딩이 지연되어 태그가 다 안열리는것을 방지하기 위해 처음으로 회기

4. 부모 태그중에서 텍스트를 가져온다.

5. 임시배열에 줄바꿈으로 각 값들을 저장

6. 혹여나 로딩이 늦어서 썸네일 링크가 없으면 링크가 로딩될때까지 키 다운을 하나씩 늘려가면서 기다린다.

7. 다음을 위한 페이지다운을 불린값을 비교하여 진행해라

8. 결과 배열에 해당 값들을 넣어라

9. 시트에 출력

10. 결과 화면처럼 사용자함수를 통해서 화면을 구성해라

 

* 2023.06.13 일부수정됨

 

 

Option Explicit
Sub Haja_Guid()
    
    Dim guid
    Dim str
    guid = Array("{0277FC34-FD1B-4616-BB19-A9AABCAF2A70}", _
                 "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", _
                 "{662901FC-6951-4854-9EB2-D9A2570F2B2E}", _
                 "{F5078F18-C551-11D3-89B9-0000F81FE221}")

    
    On Error Resume Next
    For Each str In guid
        ThisWorkbook.VBProject.References.AddFromGuid str, 0, 0 '= 가장 최신버전
    Next str

    Call 크롤링

End Sub
Sub 크롤링()

    Dim Sel As New Selenium.WebDriver
    Dim key As New Selenium.Keys
    Dim Pic As Object
    Dim strurl$
    Dim result(1 To 27735, 1 To 5)
    Dim elements As Object, ele As Object, Mains As Object
    Dim Obj As Object
    Dim bln As Boolean, bl As Boolean
    Dim Vtemp
    Dim rngA As Range
    Dim prev_height, current_height
    Dim n&: n = 1
        
    Haja_Format bl
    [a3].CurrentRegion.Offset(1).ClearContents
    
    
    'Sel.AddArgument "--headless"                                     '= 헤드리스 모드
    strurl = [b1]
    Sel.Start "chrome"                                               '= 크롬으로 진행
    Sel.Get strurl
   
    Sel.Window.Maximize
    Sel.Wait 500
    prev_height = Sel.ExecuteScript("return document.documentElement.scrollHeight")
    
   '= 화면 스크롤을 맨 아래까지 내리는 구문
    Do
  
      '  DoEvents
        Sel.ExecuteScript ("window.scrollTo(0, document.documentElement.scrollHeight);")
        Sel.Wait 1000
         
        current_height = Sel.ExecuteScript("return document.documentElement.scrollHeight")
    
        If prev_height = current_height Then
        
            Exit Do
        Else
            prev_height = current_height
        End If
          
    Loop
   '= 화면 스크롤을 맨 아래까지 내리는 구문
 

   Set Mains = Sel.FindElementsByCss("#dismissible")
   Sel.ExecuteScript ("window.scrollTo(0, 100);")
   
        For Each ele In Mains
        
            Set elements = ele.FindElementByCss("#details")
            Vtemp = Split(elements.Text, Chr(10))
            
           '= 로딩이 늦어서 썸네일 링크가 없으면 나올때까지 반복
            Do Until ele.FindElementByCss("img").Attribute("src") <> ""
            
               Sel.SendKeys (key.Down)    '= 키 다운을 눌러서 링크가 나올때까지 반복
               bln = True
            Loop
            
            If bln = True Then
                Sel.SendKeys (key.PageDown)     '= 페이지 다운을 눌러서 계속 크롤링
                bln = False
            End If
            
            result(n, 1) = ele.FindElementByCss("img").Attribute("src")    '= 썸네일 링크
            result(n, 2) = Vtemp(0)                                        '= 제목
            result(n, 3) = Vtemp(1)                                        '= 조회수
            result(n, 4) = Vtemp(2)                                        '= 게시일
            result(n, 5) = ele.FindElementByCss("#video-title-link").Attribute("href")  '= 링크
            n = n + 1
          
        Next ele

         Sel.Close
         [a4].Resize(n, 5) = result
         
         For Each rngA In Range([a4], [a4].End(4))
         
            Set Pic = ActiveSheet.Pictures.Insert(Split(rngA.Value, "?")(0))   '= 썸네일 시트에 삽입
            
            rngA = insert_pic(rngA, Pic)
            rngA.ClearContents
            
            rngA(1, 2) = Haja_href(rngA(1, 2), rngA(1, 5))                     '= 제목에 링크걸기
            rngA(1, 5).ClearContents
         Next rngA
   
    
    MsgBox "목록추출을 완료했습니다."
    
            
End Sub

Function Haja_href(rng As Range, url$)

    Dim Ws As Worksheet: Set Ws = ActiveSheet

    Ws.Hyperlinks.Add anchor:=rng, Address:=url, ScreenTip:="[웹브라우저 연결]"
    rng.Font.Underline = xlUnderlineStyleNone
    rng.Font.Color = rgbDarkBlue
    rng.Font.Bold = True
    rng.Font.Size = 10
    
    Haja_href = rng

End Function
    

Function insert_pic(rngX As Range, Pic As Variant)

    rngX.RowHeight = 70                                                   '= 행높이

    With Pic
        .ShapeRange.LockAspectRatio = msoFalse                            '= 사진의 가로세로 고정비율 해제
        .Top = rngX(1, 1).Top + 1
        .Left = rngX(1, 1).Left + 1
        .Width = rngX(1, 1).Width - 2
        .Height = rngX(1, 1).Height - 2
    End With

End Function

Function Haja_Format(bl As Boolean)
    Dim Obj As Object
    
    If bl = False Then
    
        [a3].CurrentRegion.Borders.LineStyle = xlNone
        
        For Each Obj In ActiveSheet.Pictures
        
            If Obj.Name <> "Button 1" Then Obj.Delete
        
        Next Obj
    
    Else
        [a3].CurrentRegion.Borders.LineStyle = 1
        
    End If
End Function

오늘도 맛있는 코드 냠냠

유튜브목록가져오기(티스토리용).xlsm

0.74MB