[VBA] 네이버 Place에서 내가 원하는 곳 정보를 가져오기

https://www.youtube.com/watch?v=ZWSoyjhmYNM 

다잡님의 [윤자동] 채널에 올라온 강의를 토대로 네이버 Place에서 원하는 검색어의 자료를 가져오는 크롤링 구문이다.

빈번한 크롤링 운영은 네이버 측으로부터 IP Block을 당할 수 있기에 학습 목적으로 사용하며, 네이버 서버에 부담없을 정도로 사용하기를 바란다.

Option Explicit

Sub Haja_네이버_Place()

    Dim rngX As Range: Set rngX = [b5]
    Dim strUrl$
    Dim strkword$
    Dim Shp As Shape
    Dim response, test As Object
    Dim con, Pic As Object
    Dim json As Object
    Dim N&, i&, TagCnt&, pageCnt&, Cnt&
    
    초기화
    strkword = fn.ENCODEURL([d2])
    
    Do Until pageCnt >= [h2]
         pageCnt = pageCnt + 1
         strUrl = "https://map.naver.com/v5/api/search?caller=pcweb&query=" & strkword & _
                  "&type=all&page=" & pageCnt & "&displayCount=20"
         
         response = fn.Request(strUrl)
        
         response = Split(response, """list""" & ":")(1)
        
         Set json = JsonConverter.ParseJson(response)
         
         For i = 1 To 20
         
             N = N + 1
             rngX = N                                                             '= 연번
             On Error Resume Next
                Set Pic = ActiveSheet.Pictures.Insert(json(i)("thumUrl"))         '= 매장사진
                With Pic
                    .ShapeRange.LockAspectRatio = msoFalse                        '= 사진의 가로세로 고정비율 해제
                    .Top = rngX(1, 2).Top + 1
                    .Left = rngX(1, 2).Left + 1
                    .Width = rngX(1, 2).Width - 2
                    .Height = rngX(1, 2).Height - 2
                End With
             On Error GoTo 0
             
             rngX(1, 3) = json(i)("name")                                       '= 상호명
             rngX(1, 4) = json(i)("category")(2)                                '= 구분
             rngX(1, 5) = json(i)("roadAddress")                                '= 주소
             rngX(1, 6) = json(i)("telDisplay")                                 '= 전화번호
             
                 For Each con In json(i)("context")                             '= 태그 중 4개만 조합
                     TagCnt = TagCnt + 1                                        '= 태그 카운트
                     rngX(1, 7) = rngX(1, 7) & IIf(rngX(1, 7) = "", "", "/") & con
                     If TagCnt >= 4 Then Exit For
                 Next con
                 
             rngX(1, 8) = json(i)("reviewCount")                                 '= 리뷰수
             Set rngX = rngX.Offset(1)                                           '= 다음 행
             TagCnt = 0                                                          '= 태그 수 초기화
         Next i
    Loop

    Columns("d:i").AutoFit
    [b4].CurrentRegion.EntireRow.RowHeight = 40
    [b4].CurrentRegion.Borders.LineStyle = 1
End Sub

Sub 초기화()

    Dim Shp As Shape
    
    For Each Shp In ActiveSheet.Shapes
        If InStr(Shp.Name, "Pic") > 0 Then Shp.Delete
    Next Shp
    On Error Resume Next
        [b4].CurrentRegion.Borders.LineStyle = xlNone
        Range([i4], [b4].End(4)).Offset(1).ClearContents
    On Error GoTo 0
End Sub

맛집리스트(22.06.14).xlsm

0.08MB