네이버지도검색 결과를 엑셀로 수집하는 매크로입니다.
검색어를 입력하고
오른쪽 단위와 제한 갯수를 설정하고 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자료구조가 변경되면 작동하지 않습니다.
카테고리별로 정렬할 수 있는 버전입니다.
특히 리뷰순으로 정렬을 선택하면 리뷰 많은 곳 우선으로 정렬합니다. 나머지 카테고리는 올림차순 정렬입니다.
ㅇ우편번호까지 검색하는 버전입니다. [2023.08.08]
지식인 답변에는 올렸었는데 여기에는 이제야 올립니다.
우편번호 검색은 시간이 걸립니다. 서버 부담을 줄이기 위해 대기시간도 걸었습니다.
※ 서버 자료/코드 변동시 언제라도 작동이 안될 수 있습니다.
(For Loop초기화 에러가 나는 경우가 있어 Dictionary 선언할 때 초기화되도록 New 구분자를 추가했습니다.)
ㅇ우편번호 가져오는 데 실패하면 juso.go.kr을 이용한 아래 방법으로 우편번호를 가져오세요. 마지막 건물이름은 삭제해야 검색 성공확률이 높습니다.
https://konahn.tistory.com/entry/jusogokr
'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 |
최근댓글