[VBA] 맛집리스트 지도맵핑

 

https://1stminokingdom.tistory.com/123

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

맛집관련한 글에 이번에는 구글맵에 맛집 리스트를 맵핑하는 방법에 대해서 알아보겠다.
지도 api를 받은 후 표시하면 가장 깔끔할거 같은

데 녹녹치 않아서 구글맵에 체크하는 방법으로 우회하였다.

구글맵 버튼을 누르면

이런식으로 웹브라우저가 생기는데 2013버전 이후로는 레지스트를 일부 수정하여야 제대로 구현이 된다고 한다.
https://hestal.tistory.com/324#gsc.tab=0

엑셀 VBA : WebBrowser 오류 문제 해결

참고하여 원하는 결과물이 나오기 바란다.

브라우저가 보여진다고 해도 웹브라우저가 ie 기반이어서 엣지 브라우저가 띄워지면서 구글 로그인에 대한 최초 1회 팝업이 발생하는데 그 모든 일련의 귀차니즘을 이겨내면 본인과 같은 결과가 나올 것이다.

코드 진행은 이렇다.
[Search] 버튼을 누르면 이전글과는 달리 상호명과 구분 사이에 업소의 경도 위도가 숨겨진 채 가져오게 된다.
우린 그걸 상호명 경도 위도 의 내용을 복사한 후 이걸 새로운 워크북을 생성하여 거기에 붙혀넣기 한후 새로운 엑셀 파일을 만들게 된다. 그 파일은 현재 맛집리스트 파일이 있는 같은 경로에 추출이 되며, 구글맵 버튼을 눌러서 생성된 웹브라우저에 이 파일을 순서대로 업로드 하면 끝이다.
gif로 함께 첨부하니 보면서 따라하시면 본인과 같이 구현이 될것이다.

Option Explicit
Sub haja_Map()
    objWebBrowser.Show 0                                                        '= 구글 맵 호출
End Sub
Sub Haja_네이버_Place()

    Dim rngX As Range: Set rngX = [b5]
    Dim strUrl$
    Dim strkword$
    Dim shp As Shape
    Dim response
    Dim con, Pic As Object
    Dim json As Object
    Dim N&, i&, TagCnt&, pageCnt&, Cnt&
    
    초기화
    strkword = fn.ENCODEURL([d2])
    
    Do Until pageCnt >= [k2]
         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)("x")                                          '= 경도
             rngX(1, 5) = json(i)("y")                                          '= 위도
             rngX(1, 6) = json(i)("category")(2)                                '= 구분
             rngX(1, 7) = json(i)("roadAddress")                                '= 주소
             rngX(1, 8) = json(i)("telDisplay")                                 '= 전화번호
             
                 For Each con In json(i)("context")                             '= 태그 중 4개만 조합
                     TagCnt = TagCnt + 1                                        '= 태그 카운트
                     rngX(1, 9) = rngX(1, 9) & IIf(rngX(1, 9) = "", "", "/") & con
                     If TagCnt >= 4 Then Exit For
                 Next con
                 
             rngX(1, 10) = json(i)("reviewCount")                               '= 리뷰수
             Set rngX = rngX.Offset(1)                                          '= 다음 행
             TagCnt = 0                                                         '= 태그 수 초기화
         Next i
    Loop
    
    [b4].CurrentRegion.EntireRow.RowHeight = 40                                 '= 행높이
    [b4].CurrentRegion.Borders.LineStyle = 1
    Call Haja_file_Export                                                       '= 구글맵 업로드를 위한 파일 생성
End Sub
Sub Haja_file_Export()                                                          '= 시트 생성하여 독립 파일로 저장

    Dim strPath As String
    Dim Str$: Str = [d2]
    Application.ScreenUpdating = False

    strPath = ThisWorkbook.Path & "\"
   
    Range([d4], [f4].End(4)).Copy                                               '= 상호명/경도/위도 영역을 복사
  
    Workbooks.Add                                                               '= 새로운 워크북 생성
    ActiveSheet.Paste [a1]                                                      '= 그곳에 복사 붙혀넣기
  
    Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=strPath & Str & Format(Date, "yymmdd") & ".xlsx"
        ActiveWorkbook.Close                                                    '= 파일 생성후 저장하고 닫아라
    Application.DisplayAlerts = True
   

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([k4], [b4].End(4)).Offset(1).ClearContents
    On Error GoTo 0
End Sub

이분 채널에 들어가면 구글맵을 200% 활용하는 법이 있으니 아직 본인처럼 구글맵 사용에 익숙하지 않은 분들은 방문하여 시청하시기를 권장한다.

https://www.youtube.com/watch?v=KKId9eUbLxc&t=219s

 

맛집리스트(22.06.20).xlsm

0.12MB