ABOUT ME

-

Today
-
Yesterday
-
Total
-
  • [추가기능] 주소변환(지번주소, 도로명주소, 우편번호)
    VB(A) 2018.06.22 15:11


    [추가기능]

    첨부를 클릭하면 추가기능이 생성되어

    추가기능의 버튼을 누르면 지번주소, 도로명주소, 우편번호를 추출해주는 매크로

    http://cafe.naver.com/excelmaster/152667 참고


    Option Explicit
    Option Base 1
     
    Sub Macro()
     
        Dim AddressRange As Range
        Dim v
        Dim addv(), v1 As String
        Dim r As Integer
        Dim i As Integer
        Dim sT As Date: sT = Time   '시작시간
        Dim nT As Date
        Dim oT As Date
        
        With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
        End With
        
        On Error GoTo err
            Set AddressRange = Application.InputBox(prompt:="주소가 있는 영역을 선택하세요", Title:="주소 선택", Type:=8)
        On Error GoTo 0
        
        v = AddressRange
        r = UBound(v)
        ReDim addv(r)
        
        Workbooks.Add
        
        For i = 1 To r
        
            nT = Time - sT
            If nT <> oT Then
                DoEvents
                Application.StatusBar = "Progress : " & i & " / " & r & "(" & Format(i / r, "0.00%"& ")" & ", " & Format(nT, "hh:mm:ss")
                oT = nT
            End If
            
            v1 = v(i, 1)
            addv(i) = ConvertAddress(v1)
        Next
        
        Range("A1:D1"= Array("주소""지번주소""도로명주소""우편번호")
        
        With Range("A2").Resize(r)
            .Value = v
            With .Offset(, 1)
                .Value2 = Application.Transpose(addv)
                .Replace What:="<b>", Replacement:=""
                .Replace What:="</b>", Replacement:=""
                .TextToColumns Destination:=.Cells, Comma:=True, DataType:=xlDelimited
            End With
            
            .Offset(, 2).Replace What:=";;;", Replacement:=","
            .CurrentRegion.Columns.AutoFit
        End With
        
    err:
        With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .StatusBar = "Progress : 100%" & ", " & Format(Time - sT, "hh:mm:ss")
        End With
        
    End Sub
     
    Function ConvertAddress(MyText As String)
     
        Dim oHtml As Object
        Dim myurl As String, postData As String
        Dim winHttpReq As Object
        Dim tmp As String
            
        myurl = "http://www.juso.go.kr/support/AddressMainSearch.do?searchType=TOTAL"   '주소 변환 사이트
        postData = "searchKeyword=" & ENDECODingURL(MyText)
        
        Set oHtml = CreateObject("htmlfile")
        Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
        
        With winHttpReq '검색어로 웹소스 가져오기
            .Open "POST", myurl, False
            .setRequestHeader "Content-Type""application/x-www-form-urlencoded"
            .Send (postData)
            oHtml.body.innerHTML = .responseText
        End With
        
        Set winHttpReq = Nothing
        
        On Error Resume Next
        With oHtml
            tmp = .getElementById("lndnAddr1").Value
            
            If Not .getElementById("bdNm1").Value = "" Then
            
                Select Case Right(.getElementById("rnAddr1").Value, 1)
                    Case ")"
                        tmp = tmp & "," & Left(.getElementById("rnAddr1").Value, _
                        Len(.getElementById("rnAddr1").Value) - 1& ";;; " & .getElementById("bdNm1").Value & ")"
                    Case Else
                        tmp = tmp & "," & .getElementById("rnAddr1").Value & "(" & .getElementById("bdNm1").Value & ")"
                End Select
            Else
                tmp = tmp & "," & .getElementById("rnAddr1").Value
                
            End If
            
            tmp = tmp & "," & .getElementById("bsiZonNo1").Value
        End With
        On Error GoTo 0
        ConvertAddress = tmp
        
    End Function
     
    Function ENDECODingURL(varText As String, 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"
            .execScript "function decode(s) {return decodeURIComponent(s)}""jscript"
          End With
          
        End If
        
        If blnEncode Then
          ENDECODingURL = objHtmlfile.parentWindow.encode(varText)
          
        Else
          ENDECODingURL = objHtmlfile.parentWindow.decode(varText)
        End If
        
    End Function
     
    cs


    댓글 0