26
2015
10

通过excel 实现 中文url编码批量转化

最近在做SEM需要监控每个关键词的效果,就需要给每个关键词都加一个监控链接 生成监控链接的时候需要把每个中文关键词都转换成url编码 有1000多个词每个都手动生成url 要累死,通过观察发现其实每个监控链接 在变的就是关键词那个标签 只需要把 关键词转成url编码然后 批量把关键词前面的链接和关键词后边的链接拖一下 就ok了

那么就需要批量吧 1000个关键词都转成 url编码 找了半天 终于找到一个 通过excel 实现 中文url编码批量转化 的方法,记录一下,以后也许还会用到


1、打开 excel 在工具栏空白处右键--自定义功能区  把 开发工具这个工具打勾





2、点 这个



把下面的代码复制到 右边的模块里就ok了


Public Function UrlEncode(ByRef szString As String) As String

       Dim szChar   As String

       Dim szTemp   As String

       Dim szCode   As String

       Dim szHex    As String

       Dim szBin    As String

       Dim iCount1  As Integer

       Dim iCount2  As Integer

       Dim iStrLen1 As Integer

       Dim iStrLen2 As Integer

       Dim lResult  As Long

       Dim lAscVal  As Long

       szString = Trim$(szString)

       iStrLen1 = Len(szString)

       For iCount1 = 1 To iStrLen1

           szChar = Mid$(szString, iCount1, 1)

           lAscVal = AscW(szChar)

           If lAscVal >= &H0 And lAscVal <= &HFF Then

              If (lAscVal >= &H30 And lAscVal <= &H39) Or _

                 (lAscVal >= &H41 And lAscVal <= &H5A) Or _

                 (lAscVal >= &H61 And lAscVal <= &H7A) Then

                 szCode = szCode & szChar

              Else

                 

                 szCode = szCode & "%" & Hex(AscW(szChar))

              End If

           Else

              szHex = Hex(AscW(szChar))

              iStrLen2 = Len(szHex)

              For iCount2 = 1 To iStrLen2

                  szChar = Mid$(szHex, iCount2, 1)

                  Select Case szChar

                         Case Is = "0"

                              szBin = szBin & "0000"

                         Case Is = "1"

                              szBin = szBin & "0001"

                         Case Is = "2"

                              szBin = szBin & "0010"

                         Case Is = "3"

                              szBin = szBin & "0011"

                         Case Is = "4"

                              szBin = szBin & "0100"

                         Case Is = "5"

                        szBin = szBin & "0101"

                         Case Is = "6"

                              szBin = szBin & "0110"

                         Case Is = "7"

                              szBin = szBin & "0111"

                         Case Is = "8"

                              szBin = szBin & "1000"

                         Case Is = "9"

                              szBin = szBin & "1001"

                         Case Is = "A"

                              szBin = szBin & "1010"

                         Case Is = "B"

                              szBin = szBin & "1011"

                         Case Is = "C"

                              szBin = szBin & "1100"

                         Case Is = "D"

                              szBin = szBin & "1101"

                         Case Is = "E"

                              szBin = szBin & "1110"

                         Case Is = "F"

                              szBin = szBin & "1111"

                         Case Else

                  End Select

              Next iCount2

              szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)

              For iCount2 = 1 To 24

                  If Mid$(szTemp, iCount2, 1) = "1" Then

                     lResult = lResult + 1 * 2 ^ (24 - iCount2)

                  Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)

                  End If

              Next iCount2

              szTemp = Hex(lResult)

                    szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)

           End If

           szBin = vbNullString

           lResult = 0

       Next iCount1

       UrlEncode = szCode

End Function


复制好后点左上角 文件--关闭并返回到 excel


3、在A1随便写个汉字,然后在B1  写这个函数  " =UrlEncode(A1) "   写好后直接回车 就ok了  批量的话直接拖就ok 



怎么样是不是很酷


附:把 url编码 批量 转成汉字的方法


  1. Function URLDecode(ByVal strIn)  

  2.         URLDecode = ""  

  3.         Dim sl : sl = 1  

  4.         Dim tl : tl = 1  

  5.         Dim key : key = "%"  

  6.         Dim kl : kl = Len(key)  

  7.         sl = InStr(sl, strIn, key, 1)  

  8.         Do While sl > 0  

  9.             If (tl = 1 And sl <> 1) Or tl < sl Then  

  10.                 URLDecode = URLDecode & Mid(strIn, tl, sl - tl)  

  11.             End If  

  12.             Dim hh, hi, hl  

  13.             Dim a  

  14.             Select Case UCase(Mid(strIn, sl + kl, 1))  

  15.                 Case "U" 'Unicode URLEncode  

  16.                     a = Mid(strIn, sl + kl + 1, 4)  

  17.                     URLDecode = URLDecode & ChrW("&H" & a)  

  18.                     sl = sl + 6  

  19.                 Case "E" 'UTF-8 URLEncode  

  20.                     hh = Mid(strIn, sl + kl, 2)  

  21.                     a = Int("&H" & hh) 'ascii码  

  22.                     If Abs(a) < 128 Then  

  23.                         sl = sl + 3  

  24.                         URLDecode = URLDecode & Chr(a)  

  25.                     Else  

  26.                         hi = Mid(strIn, sl + 3 + kl, 2)  

  27.                         hl = Mid(strIn, sl + 6 + kl, 2)  

  28.                         a = ("&H" & hh And &HF) * 2 ^ 12 Or ("&H" & hi And &H3F) * 2 ^ 6 Or ("&H" & hl And &H3F)  

  29.                         If a < 0 Then a = a + 65536  

  30.                         URLDecode = URLDecode & ChrW(a)  

  31.                         sl = sl + 9  

  32.                     End If  

  33.                 Case Else 'Asc URLEncode  

  34.                     hh = Mid(strIn, sl + kl, 2) '高位  

  35.                     a = Int("&H" & hh) 'ascii码  

  36.                     If Abs(a) < 128 Then  

  37.                         sl = sl + 3  

  38.                     Else  

  39.                         hi = Mid(strIn, sl + 3 + kl, 2) '低位  

  40.                         a = Int("&H" & hh & hi) '非ascii码  

  41.                         sl = sl + 6  

  42.                     End If  

  43.                     URLDecode = URLDecode & Chr(a)  

  44.             End Select  

  45.             tl = sl  

  46.             sl = InStr(sl, strIn, key, 1)  

  47.         Loop  

  48.         URLDecode = URLDecode & Mid(strIn, tl)  

  49.     End Function  

 

提示最后用函数的时候 写这个函数  " =URLDecode(A1) " 就ok



« 上一篇下一篇 »

评论列表:

1.郭大力  2015-11-2 11:07:47 回复该留言
虽然我用不到,但是还是收藏一下
2.Wade  2016-6-8 10:56:30 回复该留言
這真是太酷了!! 不知道能不能直接去掉漢字只保留網址呢?
3.121  2018-3-12 19:13:09 回复该留言
提示编译错误,语法错误

发表评论:

◎欢迎参与讨论,请在这里发表您的看法、交流您的观点。