[심화방] VBA_심화_100제 #18 [ 유튜브댓글 조회하기]

 

유튜브 댓글 관련 크롤링 코드를 올려보려한다.

문제가 될수 있어서 [답글 더보기] 까지 완전히 다 열리는 코드는 올리지 못함을 양해바란다.

 

댓글 2천개 기준으로 5분정도 소요되는거 같다.

댓글 2천개 미만은 금방되는거 같으니 코드를 한번 유심히 뜯어보시길 바란다.

 

코드진행은 이렇다.

1. 맨 하단까지 스크롤을 다 내려서 태그를 다 열어준다음

2. 댓글 버튼을 클릭해서 댓글들을 다 열어준다. 

3. 댓댓글은 다시 위로 올라가서 하나하나 다시 태그안으로 들어가서 열어줘야한다. [ 코드에는 빠져있음 ]

4. 배열에 담아서

5. 엑셀 시트에 뿌려준다..

 

2번은 스크롤을 열어서 요소를 찾은 후 모두 클릭해주면 되는데

3번은 그렇게 하면 화면에 보이는 부분만 열리게 되어서... 다시 처음부터 [답글 더보기]를 찾아서 열어야 하니까.. 본인 코드를  더 확장하고 싶은 분들은 참고해서 만들어 보시길 바란다.

 

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 strurl$
    Dim result(1 To 27735, 1 To 4)
    Dim rngX As Range: Set rngX = [a4]
    Dim Mains As Object
    Dim elements As Object, ele As Object
    Dim Obj As Object
    Dim dissBtn As Object
    Dim bln As Boolean
    Dim prev_height, current_height
    Dim targetText$
    Dim i&, r&, n&: n = 1
        
    [a3].CurrentRegion.Offset(1).ClearContents
    
    'Sel.AddArgument "--headless"                                     '= 헤드리스 모드
    strurl = [d1]
    Sel.Start "chrome"                                               '= 크롬으로 진행
    Sel.Get strurl
   
    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
    
       '= 유튜브 구독 팝업창 제거
        If bln = False Then
            If Sel.FindElementsByXPath("//*[@id='dismiss-button']/yt-button-shape/button").Count > 0 Then
               '= 요소가 있는지 없는지 확인하는 구문
                Set dissBtn = Sel.FindElementByXPath("//*[@id='dismiss-button']/yt-button-shape/button")
                dissBtn.Click
                bln = True
            End If
        End If
       '= 유튜브 구독 팝업창 제거
          
    Loop
   '= 화면 스크롤을 맨 아래까지 내리는 구문
    
   '= 모든 답글 열기
    Set elements = Sel.FindElementsByCss("#more-replies")
    For Each ele In elements
         Sel.ExecuteScript "arguments[0].click();", ele
    Next ele
    
   '= 모든 [답글 더보기] 여는 구문
   '= 모든 [답글 더보기] 여는 구문
    
   
   '= 댓글을 배열에 담는 구문
    Set Mains = Sel.FindElementsByCss("ytd-comment-thread-renderer.style-scope.ytd-item-section-renderer")
   
         For Each Obj In Mains
             
                result(n, 1) = Obj.FindElementByCss("#author-text").Text            '= 작성자
                result(n, 3) = Obj.FindElementByCss(".published-time-text").Text    '= 작성일
                
                targetText = Obj.FindElementByCss("#content-text").Text
                If InStr(targetText, Chr(10)) Then targetText = Replace(targetText, Chr(10), "")  '= 댓글 한줄로
                '= 요소가 있는지 없는지 확인하는 구문
                
                result(n, 4) = targetText                                           '= 댓글 내용
                                            
                Set elements = Obj.FindElementsByCss("ytd-comment-renderer.style-scope.ytd-comment-replies-renderer")
                r = 1
                For Each ele In elements
                    
                    n = n + 1
                    result(n, 1) = "└"
                    result(n, 2) = "답글 : " & ele.FindElementByCss("#author-text").Text    '= 댓댓글
                    result(n, 3) = ele.FindElementByCss("#header-author > yt-formatted-string > a").Text '= 댓댓글 작성일
                    targetText = ele.FindElementByCss("#content-text").Text
                    If InStr(targetText, Chr(10)) Then targetText = Replace(targetText, Chr(10), "")
                    result(n, 4) = targetText                                               '= 댓글 내용
                    r = r + 1
                Next ele
                n = n + 1
                
         Next Obj
         Sel.Close
         [a4].Resize(n, 4) = result
   
    
    MsgBox "댓글 추출이 완료되었습니다."
    
         
    
End Sub

유튜브댓글관리티스토리용(23.06.08).xlsm

0.03MB

유튜브 댓글을 가지고 워크클라우드처럼 좀더 깊은 프로세스를 진행하거나 키워드 추출같은것을 할 수도 있을 것같다.

구글 생태계는 태그를 중복으로 사용하는것들이 많아서 그것을 걸러내는것이 조금 힘들었던 작업이었던걸로 기억된다.

 

많은 공부를 해보시길 바란다.