네이버 지도 검색 결과 엑셀 수집

XLS+VBA 2020. 8. 17. 13:17

네이버지도검색 결과를 엑셀로 수집하는 매크로입니다.

 

📢 주의 사항 

네이버 서버가 수정되면 언제라도 작동하지 않을 수 있습니다.
영구적인 작동을 보장하지 않으며 수정 등 유지보수를 약속하지 못합니다.

아래 VBA는 개인적인 용도로 서버에 부담을 주지 않는 범위내에서
VBA크롤링에 대한 교육적인 용도 혹은 단순 테스트 용도로만 사용되어야 합니다.

네이버 지도 API지원을 중단한 상태이므로 유료 네이버클라우드 Maps API를 이용하세요.
https://www.ncloud.com/support/notice/all/585

 

아래는 구버전 설명입니다.

 

검색어를 입력하고 

오른쪽 단위와 제한 갯수를 설정하고 Naver 지도 검색을 누르면 됩니다.

 

서울 롯데리아 검색화면:

검색된 상호를 클릭하면 웹브라우저에 해당 위치를 보여줍니다.

 

강원도 영화촬영지 검색 화면:

 

부산 맛집 검색화면:

 

특히 맛집, 주유소 등을 검색할 때 유용하겠습니다.

 

더보기 
'Alt-F11 도구-참조에서 Microsoft XML x.0 Object Library,
'Microsoft Scripting Runtime Library에 미리 체크

Option Explicit

    
Sub Automate()
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim r As Range
    Dim page As Integer
    
    Set sht = ActiveSheet
    
    '기존 자료 삭제
    lastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    sht.Range("A4:Z" & lastRow + 1).ClearContents
    
    sht.Hyperlinks.Delete
    
    '자료 가져오기
    If [B1] = "" Then
        MsgBox "검색어를 입력하세요.(예:서울 중국집)"
        [B1].Select
    ElseIf [F1] >= 1 And [F1] <= 100 And [F2] >= 1 And [F2] <= 1000 Then
    
        For page = 1 To Int(([F2] / [F1]) + 0.5)
        
            If page > 1 Then  ' And page Mod 2 = 1 Then  ' 페이지 마다 쉬기
                Application.StatusBar = Application.StatusBar & " - Pausing for 2 sec..."
                Application.Wait Now + TimeValue("00:00:02")
            End If
            Application.StatusBar = "Searching page: " & page & "..."
            '출력시트, 검색어, 페이지당 개수, 제한개수
            If SearchNaverMap(sht, [B1], [F1], page) = 0 Then Exit For
            
        Next page
    Else
        [F2].Select
        MsgBox "개수 단위는 1개이상 100개이하이며" & vbNewLine & vbNewLine _
            & "총 제한개수는 1개이상 1000개 이하여야합니다. "
    End If
    Application.StatusBar = False
    
End Sub

Function SearchNaverMap(shtTarget As Worksheet, strSearch As String, _
    Optional iCount As Integer = 20, Optional iPage As Integer = 1) As Long

    Dim http As Object 'New MSXML2.XMLHTTP
    Dim Json As Dictionary  'Object
    Dim jValue As Dictionary, v As Variant
    Dim i As Integer
    Dim URL As String, URl2 As String, temp As String
    Dim startRow As Long
     
    On Error Resume Next
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    URl2 = "https://map.naver.com/v5/search/" & strSearch & "/place/"
    URL = "https://map.naver.com/v5/api/search?caller=pcweb&query=&type=all&page=1&displayCount=20&isPlaceRecommendationReplace=true&lang=ko"
    URL = Replace(URL, "&query=", "&query=" & ENCODEURL(strSearch))
    If iPage = 0 Then iPage = 1
    URL = Replace(URL, "&page=1", "&page=" & iPage)
    If iCount = 0 Then iCount = 20
    If iCount > 100 Then iCount = 100  '최대 100개씩
    URL = Replace(URL, "&displayCount=20", "&displayCount=" & iCount)
    Debug.Print URL
    
    '접속
    With http
        .Open "get", URL, False
        .setRequestHeader ": authority", "Map.naver.com"
 
        .setRequestHeader "content-type", "application/json"
        .setRequestHeader "user-agent", "Mozilla/5.0"
        .setRequestHeader "referer", "https://map.naver.com/"
        '.setRequestHeader "cookie", "hide_intro_popup=true; NNB=YB4ZCP2KPBQF3; BMR=s=1682410501834&r=&r2=; " & _
            "nid_inf=-1200312348; NID_AUT=dDyW/jafIlmW8RZYFO/qx0sibaRZ; " & _
            "NID_JKL=bj17HrEtZWoAlqRks=; _ga_7VKFYR6RV1=GS1.1.1.0.1.60; _ga=GA1.2..; _gid=GA1.2..; " & _
            "NID_SES=AAABvjvT3; _naver_usersession_=zjDUtGtcOJ; page_uid=UE5yLlpy8ejBsd9oyAK-014447; csrf_token=dc6c34e04198ab0f1ae"
        .send
        If InStr(.responseText, "Redirecting") Then _
            MsgBox "Due to too many connections, this IP is blocked by server!!"
        If Len(.responseText) < 500 Then SearchNaverMap = 0: Set http = Nothing: Exit Function
        'Json 파싱
        Set Json = JsonConverter.ParseJson(.responseText)

    End With
    
    '에러 발생 '//{"error":{"code":"XE400","msg":"Bad Request."
    'If Json.Keys(0) = "error" Then SearchNaverMap = 0: Set http = Nothing: Exit Function
    
    '맨 아래 행
    startRow = shtTarget.Cells(shtTarget.Rows.Count, "B").End(xlUp).Row + 1
    
    For Each jValue In Json("result")("place")("list")
    
        '연번
        shtTarget.Cells(startRow + i, "A") = (iPage - 1) * iCount + i + 1
        
        '상호명
        shtTarget.Cells(startRow + i, "B") = jValue("name")
        '하이퍼링크
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + i, "B"), URl2 & jValue("id")
        
        '구분
        shtTarget.Cells(startRow + i, "C") = jValue("category")(jValue("category").Count)
        
        '주소
        shtTarget.Cells(startRow + i, "D") = jValue("address")

        '전화
        shtTarget.Cells(startRow + i, "E") = jValue("tel")
       
        '태그
        temp = ""
        For Each v In jValue("context"): temp = temp & v & ",": Next v
        If Right(temp, 1) = "," Then temp = Left(temp, Len(temp) - 1)
        shtTarget.Cells(startRow + i, "F") = temp

        '리뷰
        shtTarget.Cells(startRow + i, "G") = jValue("reviewCount")

        i = i + 1
        
    Next jValue
    
    shtTarget.Cells.Columns.AutoFit
    
Oops:
    If Not http Is Nothing Then Set http = Nothing
    If Err Then MsgBox Err.Description
    SearchNaverMap = i
    
End Function


Function ENCODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        ENCODEURL = objHtmlfile.parentWindow.encode(varText)
    End If
End Function

Function DECODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function decode(s) {return decodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        DECODEURL = objHtmlfile.parentWindow.decode(varText)
    End If
End Function

 

VBAJSON 라이브러리를 이용했습니다.

코드는 위와 같이 공개하지만 남용을 조금이라도 막고자 모듈에 암호가 걸려있습니다.

 

주1) 서버에 부담을 줄이기 위해 한번 검색 후 약간의 시간을 두었습니다.

주2) 본 자료는 웹사이트 HTML분석과 크롤링에 대한 교육용 단순샘플로 검색자료의 저작권은 해당저작권자의 소유임을 밝힙니다.

주3) HTML소스나 JSON자료구조가 변경되면 작동하지 않습니다. 

 

 

네이버지도검색3Restricted20200307.xlsm
0.09MB

(현재 작동하지 않음)

 

카테고리별로 정렬할 수 있는 버전입니다.

특히 리뷰순으로 정렬을 선택하면 리뷰 많은 곳 우선으로 정렬합니다. 나머지 카테고리는 올림차순 정렬입니다.

 

네이버지도검색4_Restricted.xlsm
0.08MB

(현재 작동하지 않음)

 

ㅇ우편번호까지 검색하는 버전입니다. [2023.08.08]

 

지식인 답변에는 올렸었는데 여기에는 이제야 올립니다.

우편번호 검색은 시간이 걸립니다. 서버 부담을 줄이기 위해 대기시간도 걸었습니다.

※ 서버 자료/코드 변동시 언제라도 작동이 안될 수 있습니다.

 

 

네이버지도검색4_Restricted_ZipCode1.xlsm
0.08MB

(현재 작동하지 않음)

(For Loop초기화 에러가 나는 경우는 대개  데이터가 제대로 수신되지 않은 경우입니다.)

 

 

 

 

[여기까지 구버전 설명이었습니다.]

 

[2024.08.22 임시로 작동하는 버전을 올립니다.]

네이버지도검색5_Restricted.xlsm
0.13MB

 

다시 한 번 말씀드리자면 언제라도 작동이 안될 수 있습니다.

문제 발생시 수정계획도 없습니다.

개인적인 용도로 테스트용으로만 사용 바랍니다.

 

 

- 기존 접속주소가 작동하지 않아 임시로 https://m.map.naver.com/search2/searchMore.naver?query=검색어 주소를 이용합니다.

- Json 라이브러리도 JsonBag으로 교체하였습니다. Dictionary를 필요로하지 않아서 Script RunTime Library가 필요 없습니다.

- 리뷰 등의 정보는 제외했습니다. 리뷰를 가져오려면 추가적인 검색에 대한 코딩이 필요합니다.

- 우편번호 검색은 아직 작동하고 있습니다.

- 상호명을 누르면 해당 상호의 모바일 홈(place)으로 이동합니다.

- 주소를 누르면 모바일 지도로 이동합니다.

- 거리뷰를 볼 수 있습니다.

- 현재 영업중인지 체크할 수 있습니다.

- 제한 개수를 너무 많이 입력하면 서버에 부담을 줍니다. 

- 특정 지역내의 상호를 검색할 때는 '애월 맛집'처럼 지역이름을 붙여서 검색하세요.

- 정렬항목을 변경하면 해당 항목 기준으로 오름차순 정렬됩니다.

 

코드는 공개합니다만 첨부파일 VBA 프로젝트에는 암호가 걸려있습니다.

클래스에 JsonBag.cls 를 추가하고 Module 하나 추가하고 아래 코드만 추가하면 됩니다.

더보기 
'Alt-F11 도구-참조에서 Microsoft XML x.0 Object Library,
'Microsoft Scripting Runtime Library에 미리 체크

Option Explicit
    
Sub Automate()
    Dim sht As Worksheet
    Dim lastrow As Long
    Dim r As Range
    Dim page As Integer
    
    Set sht = ActiveSheet
    
    '기존 자료 삭제
    lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    sht.Range("A4:Z" & lastrow + 1).ClearContents
    
    sht.Hyperlinks.Delete
    
    '자료 가져오기
    If [B1] = "" Then
        MsgBox "검색어를 입력하세요.(예:서울 중국집)"
        [B1].Select
    ElseIf [F1] >= 1 And [F1] <= 100 And [F2] >= 1 And [F2] <= 1000 Then
    
        For page = 1 To Int(([F2] / [F1]) + 0.5)
        
            If page > 1 Then  ' And page Mod 2 = 1 Then  ' 페이지 마다 쉬기
                Application.StatusBar = Application.StatusBar & " - Pausing..."
                Application.Wait Now + TimeValue("00:00:03")
            End If
            Application.StatusBar = "Searching page: " & page & "..."
            '출력시트, 검색어, 페이지당 개수, 제한개수
            If SearchNaverMap(sht, [B1], [F1], page) = 0 Then Exit For
            
        Next page
        
        If Len([E2]) Then Call SortSheet(sht)
    Else
        [F2].Select
        MsgBox "개수 단위는 1개이상 100개이하이며" & vbNewLine & vbNewLine _
            & "총 제한개수는 1개이상 1000개 이하여야합니다. "
    End If
    Application.StatusBar = False
    
End Sub

Sub SearchZipCode()
    
    Dim sht As Worksheet
    Dim lastrow As Long
    Dim rng As Range
    Dim http As Object
    
    'for speedy object
    Set http = CreateObject("MSXML2.XMLHTTP")
    If http Is Nothing Then Exit Sub
     
    Set sht = ThisWorkbook.ActiveSheet
    lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
    If lastrow < 4 Then Exit Sub
    For Each rng In sht.Range("D4:D" & lastrow)
        Call getZipCode(http, rng)
        If (rng.Row - 3) Mod 1 = 0 Then Application.Wait Now + TimeValue("00:00:01")
    Next rng
    Set http = Nothing
End Sub

Function SortSheet(oSht As Worksheet)
    Dim lastrow As Long
    Dim r As Range, key1 As Range
    
    lastrow = oSht.Cells(oSht.Rows.Count, "B").End(xlUp).Row
    If Len([E2]) Then
        For Each r In oSht.Range("A3:H3")
            If r = [E2] Then Set key1 = r.Offset(1)
        Next r
        If key1 Is Nothing Then Exit Function
 
        If [E2] = "리뷰" Then _
            oSht.Range("A4:H" & lastrow).Sort key1:=key1, Order1:=xlDescending _
        Else _
            oSht.Range("A4:H" & lastrow).Sort key1:=key1, Order1:=xlAscending
 
    End If
End Function

Function SearchNaverMap(shtTarget As Worksheet, strSearch As String, _
    Optional iCount As Integer = 75, Optional iPage As Integer = 1) As Long

    Dim http As Object 'New MSXML2.ServerXMLHTTP
    Dim JSON As New JsonBag  'Object
    Dim jValue As New JsonBag
    Dim I As Integer
    Dim URL As String, URL2 As String, temp As String, URL3 As String, URL4$, URL5$
    Dim startRow As Long
     
    'On Error Resume Next
    'Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set http = CreateObject("MSXML2.ServerXMLHTTP")
    
    If iPage = 0 Then iPage = 1
    If iCount = 0 Then iCount = 20
    If iCount > 100 Then iCount = 100  '최대 100개씩
    URL5 = "https://app.map.naver.com/panorama/?id="
    URL4 = "https://m.place.naver.com/place/[id]/location"
    URL3 = "https://m.map.naver.com/search2/site.naver?code="   '&lng=&lat=&pinTitle=
    URL2 = "https://map.naver.com/v5/search/" & strSearch & "/place/"
    'URL = "https://map.naver.com/v5/api/search?caller=pcweb&query=&type=all&page=1&displayCount=20&isPlaceRecommendationReplace=true&lang=ko"
    URL = "https://m.map.naver.com/search2/searchMore.naver?query=" & ENCODEURL(strSearch) & _
        "&siteSort=0&sm=clk&style=v5&page=" & iPage & "&displayCount=" & iCount & "&type=SITE_1"
    'Debug.Print URL
    
    '접속
    With http
        .Open "get", URL, False
        .setRequestHeader "accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/png,image/svg+xml,*/*;q=0.8"
        .setRequestHeader "user-agent", "Mozilla/5.0"   '"Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:128.0) Gecko/20100101"
        .setRequestHeader "content-type", "application/json"
        .setRequestHeader "host", "m.map.naver.com"
        .send
        'Debug.Print .responseText
        If Len(.responseText) < 500 Then SearchNaverMap = 0: Set http = Nothing: Exit Function
        'Json 파싱
        JSON.JSON = .responseText
    End With
    
    'If not Json.Exist("result")  Then SearchNaverMap = 0: Set http = Nothing: Exit Function
    
    '맨 아래 행
    startRow = shtTarget.Cells(shtTarget.Rows.Count, "B").End(xlUp).Row + 1
    
    For Each jValue In JSON("result")("site")("list")
    
        '연번
        shtTarget.Cells(startRow + I, "A") = (iPage - 1) * iCount + I + 1
        
        '상호명
        shtTarget.Cells(startRow + I, "B") = jValue("name")
        '하이퍼링크
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + I, "B"), URL3 & jValue("id")
       
        '구분
        shtTarget.Cells(startRow + I, "C") = jValue("category")(jValue("category").Count)
        
        '주소
        shtTarget.Cells(startRow + I, "D") = jValue("address")
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + I, "D"), Replace(URL4, "[id]", jValue("id"))
        'shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + I, "D"), URL2 & jValue("id") & "?c=" & _
            "?,?,15,0,0,0,dhci" & "&lng=" & jValue("x") & "&lat=" & jValue("y") & "&type=3&title=" & ENCODEURL(jValue("name"))

        '전화
        shtTarget.Cells(startRow + I, "E") = jValue("tel")
       
        '영업중
         
        shtTarget.Cells(startRow + I, "F") = jValue("bizhourInfo")

        '거리뷰
        shtTarget.Cells(startRow + I, "G") = "뷰"
        temp = jValue("streetPanorama")("id")
        temp = Left(temp, Len(temp) - 2)
        temp = Replace(temp, "+", "-")
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + I, "G"), _
            URL5 & temp & _
            "&holder=place&linkType=1&tilt=" & jValue("streetPanorama")("tilt")
        
        'Homepage
        shtTarget.Cells(startRow + I, "H") = "Visit"
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + I, "H"), jValue("homePage")
        
        I = I + 1
        
    Next jValue
    
    shtTarget.Cells.Columns.AutoFit
    
Oops:
    If Not http Is Nothing Then Set http = Nothing
    If Err Then MsgBox Err.Description
    SearchNaverMap = I
    
End Function

Function getZipCode(xHttp As Object, addr As Range)

    Dim JSON As New JsonBag  'Object
    Dim jValue As New JsonBag, v As Variant
    Dim I As Integer
    Dim URL As String, PostData As String, JStr As String
    Dim startRow As Long
     
    'On Error Resume Next
    URL = "https://pcmap-api.place.naver.com/graphql"
    
    '접속
    With xHttp
        .Open "post", URL, False
        .setRequestHeader "accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
        .setRequestHeader "user-agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/115.0.0.0 Safari/537.36"
        .setRequestHeader "authority", "Map.naver.com"
        .setRequestHeader "content-type", "application/json"
        '[{"operationName":"GetSearchZipcodeByQuery","variables":{"address":"제주 제주시 애월읍 애월북서길 32 lazypump","isNx":false},"query":"query GetSearchZipcodeByQuery($address: String!, $isNx: Boolean) {\n  searchZipCodeByQuery: searchZipCodeByQuery(address: $address, isNx: $isNx) {\n    zipCode\n    __typename\n  }\n}\n"}]

        PostData = "[{""operationName"":""GetSearchZipcodeByQuery"",""variables"":{""address"":""%address%"",""isNx"":false},""query"":""query GetSearchZipcodeByQuery($address: String!, $isNx: Boolean) {\n  searchZipCodeByQuery: searchZipCodeByQuery(address: $address, isNx: $isNx) {\n    zipCode\n    __typename\n  }\n}\n""}]"
        PostData = Replace(PostData, "%address%", addr)
        .send PostData
        'Debug.Print PostData
        JStr = .responseText
        
        '//****for debug
        'Debug.Print URL
        'Debug.Print JStr
        '//*****
        
       '[{"data":{"searchZipCodeByQuery":{"zipCode":"63053","__typename":"SearchZipCodeByQueryResult"}}}]

        If InStr(JStr, "500 Internal Server Error") Then
            'Debug.Print addr
            addr.Offset(, 5) = "Error!"
        ElseIf InStr(JStr, "Too many request") Then
            addr.Offset(, 5) = "Busy!"
            Exit Function
        End If
        'Json 파싱
        If Left(JStr, 1) = "[" Then JStr = Mid(JStr, 2)
        If Right(JStr, 1) = "]" Then JStr = Left(JStr, Len(JStr) - 1)
        'Debug.Print JStr
        JSON.JSON = JStr
        addr.Offset(, 5) = JSON("data")("searchZipCodeByQuery")("zipCode")
    End With
    
End Function

Function ENCODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        ENCODEURL = objHtmlfile.parentWindow.encode(varText)
    End If
End Function

 

 

ㅇ우편번호 가져오는 데 실패하면 juso.go.kr을 이용한 아래 방법으로 우편번호를 가져오세요. 마지막 건물이름은 삭제해야 검색 성공확률이 높습니다.

 

https://konahn.tistory.com/entry/jusogokr

 

juso.go.kr이용 한글주소 ↔ 영어주소 변환

관련: 지식인 ✅ 기능 소개 위 도로명주소 검색사이트 https://juso.go.kr 의 주소 검색 서비스를 이용해서 주어진 엑셀 주소 목록에 대해 검색결과가 있는 경우 한글 도로명주소, 지번주소, 우편번호

konahn.tistory.com

 

 

 

ㅇ네이버맵이 작동하지 않으면 카카오맵 등을 이용하세요.

 

- VBAJSON라이브러리(이름은 JsonConverter로 변경)를 이용합니다.

- 다음 REST API를 발급받아 만들 수 있습니다.

https://developers.kakao.com/console/app

-  모듈하나 추가하고 아래 코드를 붙여넣고 [I2]셀에 REST API키를 수정하면 됩니다. 

 

더보기

 

'Alt-F11 도구-참조에서 Microsoft XML x.0 Object Library,
'Microsoft Scripting Runtime Library에 미리 체크

Option Explicit

Const CountPerPage As Integer = 15
Dim http As Object 'New MSXML2.XMLHTTP

Sub Automate()
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim r As Range
    Dim page As Integer
    
    Set sht = ActiveSheet
    
    '기존 자료 삭제
    'lastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    'sht.Range("A4:Z" & lastRow + 1).ClearContents
    
    'sht.Hyperlinks.Delete
    
    '자료 가져오기
    If [B1] = "" Then
        MsgBox "검색어를 입력하세요.(예:서울 중국집)"
        [B1].Select
    ElseIf [G1] >= 1 And [G2] <= 45 Then
    
        For page = [G1] To [G2]
        
            If page > [G1] Then  ' And page Mod 2 = 1 Then  ' 페이지 마다 쉬기
                Application.StatusBar = Application.StatusBar & " - Pausing for 2 sec..."
                Application.Wait Now + TimeValue("00:00:02")
            End If
            Application.StatusBar = "Searching page: " & page & "..."
            '출력시트, 검색어, 페이지당 개수, 제한개수
            If SearchKakaoMap(sht, [B1], CountPerPage, page) = 0 Then Exit For
            'Exit For
        Next page
        
        If Len([E2]) Then Call SortSheet(sht)
    Else
        [G1].Select
        MsgBox "시작페이지는 1이상이고 " & vbNewLine & vbNewLine _
            & "종료페이지는 45페이지이하여야합니다. "
    End If
    Application.StatusBar = False
    If Not http Is Nothing Then Set http = Nothing
End Sub

Function SortSheet(oSht As Worksheet)
    Dim lastRow As Long
    Dim r As Range, key1 As Range
    
    lastRow = oSht.Cells(oSht.Rows.Count, "B").End(xlUp).Row
    If Len([E2]) Then
        For Each r In oSht.Range("A3:H3")
            If r = [E2] Then Set key1 = r.Offset(1)
        Next r
        If key1 Is Nothing Then Exit Function
 
        If [E2] = "리뷰" Then _
            oSht.Range("A4:H" & lastRow).Sort key1:=key1, Order1:=xlDescending _
        Else _
            oSht.Range("A4:H" & lastRow).Sort key1:=key1, Order1:=xlAscending
 
    End If
End Function

Function getResponse(sUrl As String, dHeader As Dictionary)
    Dim key As Variant
    
    If http Is Nothing Then _
        Set http = CreateObject("MSXML2.ServerXMLHTTP")
        
    '접속
    With http
        .Open "get", sUrl, False
        For Each key In dHeader.Keys
            .setRequestHeader key, dHeader(key)
        Next key
        .send
        getResponse = .responseText
    End With

End Function

Function SearchKakaoMap(shtTarget As Worksheet, strSearch As String, _
    Optional iCount As Integer = 15, Optional iPage As Integer = 1) As Long
    Dim dHeaderMap As Dictionary
    Dim Json As Dictionary  'Object
    Dim jValue As Dictionary, v As Variant
    Dim i As Integer
    Dim URL As String, URl2 As String, temp As String, URL3 As String
    Dim startRow As Long
     
    On Error Resume Next

    'https://search.map.daum.net/mapsearch/map.daum?callback=jQuery18109436309113269068_1607586645842&q=%EB%A1%AF%EB%8D%B0%EB%A6%AC%EC%95%84&msFlag=A&sort=0
    'https://apis.map.kakao.com/web/documentation/#services_Places_keywordSearch
    
    If iPage = 0 Then iPage = 1
    If iCount = 0 Then iCount = CountPerPage
    
    URL = "https://dapi.kakao.com/v2/local/search/keyword.json?"
    URL = URL & "&page=" & iPage & "&size=" & iCount & "&query=" & ENCODEURL(strSearch)

    Debug.Print URL
    
    Set dHeaderMap = New Dictionary
    dHeaderMap.Add "Accept", "*/*"
    'dHeaderMap.Add "Accept-Encoding", "gzip , deflate, br"
    dHeaderMap.Add "Accept-Language", "ko-KR,ko;q=0.9,en-US;q=0.8,en;q=0.7"
    dHeaderMap.Add "Connection", "keep-alive"
    dHeaderMap.Add "Content-Type", "application/json; charset=utf-8"
    dHeaderMap.Add "DNT", "1"
    dHeaderMap.Add "Host", "dapi.kakao.com" '"Search.Map.daum.net"
    dHeaderMap.Add "Referer", "https://map.kakao.com/"
    dHeaderMap.Add "Sec-Fetch-Dest", "Script"
    dHeaderMap.Add "Sec-Fetch-Mode", "no-cors"
    dHeaderMap.Add "Sec-Fetch-site", "cross-site"
    dHeaderMap.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
    'KakaoAK API key
    'dHeaderMap.Add "Authorization", "KakaoAK abcdefghijlmnopqrstuvwxyz1234567"  'REST
    dHeaderMap.Add "Authorization", [I2]
     Debug.Print getResponse(URL, dHeaderMap)

    Set Json = JsonConverter.ParseJson(getResponse(URL, dHeaderMap))
    
    '맨 아래 행
    startRow = shtTarget.Cells(shtTarget.Rows.Count, "B").End(xlUp).Row + 1
  
    For Each jValue In Json("documents")
    
        shtTarget.Cells(startRow + i, "A").Resize(, 10).ClearContents
        
        '연번
        shtTarget.Cells(startRow + i, "A") = shtTarget.Cells(startRow + i, "A").Row - 3 '(iPage - 1) * iCount + i + 1
        
        '상호명
        shtTarget.Cells(startRow + i, "B") = jValue("place_name")
        
        '하이퍼링크
        shtTarget.Hyperlinks.Add shtTarget.Cells(startRow + i, "B"), jValue("place_url")
          
        '구분
        shtTarget.Cells(startRow + i, "C") = jValue("category_group_name")
        
        '주소
        shtTarget.Cells(startRow + i, "D") = jValue("road_address_name") & "(" & jValue("address_name") & ")"

        '전화
        shtTarget.Cells(startRow + i, "E") = jValue("phone")
       
        '태그
        shtTarget.Cells(startRow + i, "F") = jValue("category_name")

        '우편번호
        shtTarget.Cells(startRow + i, "F") = jValue("road_address")("zone_no")

        '리뷰
        'shtTarget.Cells(startRow + i, "G") = jValue("reviewCount")

        i = i + 1
        
    Next jValue
    
    shtTarget.Cells.Columns.AutoFit
    
Oops:
 
    If Err Then
        SearchKakaoMap = 0
        MsgBox Err.Description
    Else
        SearchKakaoMap = i
    End If
End Function


Function ENCODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        ENCODEURL = objHtmlfile.parentWindow.encode(varText)
    End If
End Function

Function DECODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function decode(s) {return decodeURIComponent(s)}", "jscript"
        End With
    End If
    If blnEncode Then
        DECODEURL = objHtmlfile.parentWindow.decode(varText)
    End If
End Function

Sub getZipcode()
    
    Dim shtTarget As Worksheet
    Dim rng As Range
    Dim dHeaderMap As Dictionary
    Dim Json As Dictionary  'Object
    Dim i As Integer
    Dim URL As String
    Dim lastRow As Long
     
    On Error Resume Next

    Set shtTarget = ActiveSheet
    '맨 아래 행
    lastRow = shtTarget.Cells(shtTarget.Rows.Count, "D").End(xlUp).Row
    
    Set dHeaderMap = New Dictionary
    dHeaderMap.Add "Accept", "*/*"
    'dHeaderMap.Add "Accept-Encoding", "gzip , deflate, br"
    dHeaderMap.Add "Accept-Language", "ko-KR,ko;q=0.9,en-US;q=0.8,en;q=0.7"
    dHeaderMap.Add "Connection", "keep-alive"
    dHeaderMap.Add "Content-Type", "application/json; charset=utf-8"
    dHeaderMap.Add "DNT", "1"
    dHeaderMap.Add "Host", "dapi.kakao.com" '"Search.Map.daum.net"
    dHeaderMap.Add "Referer", "https://map.kakao.com/"
    dHeaderMap.Add "Sec-Fetch-Dest", "Script"
    dHeaderMap.Add "Sec-Fetch-Mode", "no-cors"
    dHeaderMap.Add "Sec-Fetch-site", "cross-site"
    dHeaderMap.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
    'KakaoAK API key
    'dHeaderMap.Add "Authorization", "KakaoAK abcdefghijlmnopqrstuvwxyz1234567"  'REST
    dHeaderMap.Add "Authorization", [I2]
    'Debug.Print getResponse(URL, dHeaderMap)
     
     
    For Each rng In shtTarget.Range("D4:D" & lastRow)
        
        URL = "https://dapi.kakao.com/v2/local/search/address.json?analyze_type=similar"
        URL = URL & "&page=1&size=1" & "&query=" & ENCODEURL(rng.Text)
    
        Set Json = JsonConverter.ParseJson(getResponse(URL, dHeaderMap))
 
        shtTarget.Cells(rng.Row, "G") = jValue("road_address")("zone_no")

 
        i = i + 1
        
    Next rng
    
Oops:
    If Err Then MsgBox Err.Description
 
End Sub

 

 

KakaoMap4_RestAPIkey.xlsm
0.08MB

 

카카오맵은 정식 API키를 발급받아 [I2]셀에 입력해서 사용해야 합니다.

카카오맵의 정책변경이 되면 지원하지 않을 수 있고 검색이 제한될 수도 있습니다.

REST API키가 맞지 않으면 데이터를 받아오지 못하므로 For 루프 초기화 에러가 뜹니다.

역시 계속적인 작동을 보장하지 않고 문제 발생시 유지보수에 대한 보장도 하지 못합니다.

 

우편번호 검색 추가 버전:

KakaoMap4PostCode_RestAPIkey.xlsm
0.08MB

 

저작자표시 비영리 동일조건

'XLS+VBA' 카테고리의 다른 글

Alt+F11 및 VBE창 금지/ 활성화  (0) 2022.01.02
고프로(Gopro) 촬영한 동영상 MP4 파일명을 촬영날짜로 일괄 변경  (9) 2021.04.17
엑셀 각 시트를 10행씩 끊어서 파워포인트 각 슬라이드에 붙여넣기  (0) 2021.02.16
네이버카페 최신글 가져오기  (37) 2020.11.19
VBA에서 Selenium 개체를 이용해서 웹 스크래핑  (14) 2020.02.16
WordReference.com 사전 단어 자동 검색 및 MP3다운로드  (36) 2019.12.24
[VB/VBA] WSOCK32.DLL이용한 주기적인 Ping 모니터링  (0) 2019.06.06
폴더내 파일명 일괄 변경  (3) 2019.04.03

티스토리툴바