標題: 用excel上網查音標又故障了，不知那裡出問題？ [打印本頁]

---

作者: 自我感覺良好    時間: 2015-5-28 06:38     標題: 用excel上網查音標又故障了，不知那裡出問題？

[attach]21050[/attach]

---

作者: 自我感覺良好    時間: 2015-5-29 22:21

[attach]21064[/attach]只能回傳一些中譯…

---

作者: Hsieh    時間: 2015-5-30 00:10

回復 2# 自我感覺良好

1. Sub Macro1()
   
2. '
   
3. ' Macro1 Macro
   
4. '
   
5. ' 快速鍵: Ctrl+p
   
6. 
   
7.     Columns("B:B").Select
   
8.     With Selection.Font
   
9.         .Name = "Arial Unicode MS"
   
10.         .Size = 12
    
11.     End With
    
12. Range("a1").Select
    
13. 
    
14. Dim XH As Object
    
15. 
    
16.     Dim rng As Range
    
17.    
    
18.       Dim iurl, iurl2 As String
    
19.     '清除已有的解釋及音標
    
20.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
    
21.     iurl2 = "http://dict.tw/index.pl?query="
    
22.     For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("a65536").End(xlUp))
    
23.             rng.Select
    
24.             If rng.Value <> "" Then
    
25.               rng.Select
    
26.               Set XH = CreateObject("Microsoft.XMLHTTP")
    
27.                     With XH
    
28.                         .Open "get", iurl & rng, False
    
29.                         .send
    
30.                         ' On Error Resume Next
    
31.                         '從Yahoo字典摘取第一組中文翻譯
    
32.                         n = .responseText
    
33.                          If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
    
34.                         '摘取KK音標
    
35.                         If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
    
36.                         .Open "get", iurl2 & rng, False
    
37.                         .send
    
38.                         '從DICT.TW 英漢字典擷取字義
    
39.                         If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
    
40.                     End With
    
41.              End If
    
42.     Next
    
43. End Sub

複製代碼

---

作者: 自我感覺良好    時間: 2015-5-30 05:43

回復 3# Hsieh
n = .responseText
                         If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
                        '摘取KK音標
                        If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
                        .Open "get", iurl2 & rng, False
                        .send
                        '從DICT.TW 英漢字典擷取字義
                        If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
                    End With
             End If
    Next
End Sub


換個方法就可以用了…
真的太感謝了。

---

作者: 自我感覺良好    時間: 2015-5-31 07:46

回復 4# 自我感覺良好

[attach]21065[/attach]

外行人把它改成這樣，程式應該還可以更簡易的

Sub searchIT(rng As Range)
    Dim XH As Object
    Dim shpRm As Shape
    Columns("B:B").Select
    With Selection.Font
        .Name = "Arial Unicode MS"
        .Size = 12
    End With
Range("a1").Select
      Dim iurl, iurl2 As String
    '清除已有的解釋及音標
    iurl = "http://tw.dictionary.search.yahoo.com/search?p="
    iurl2 = "http://dict.tw/index.pl?query="
    For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("a50").End(xlUp))
            rng.Select
            If rng.Value <> "" Then
              rng.Select
              Set XH = CreateObject("Microsoft.XMLHTTP")
                    With XH
                        .Open "get", iurl & rng, False
                        .send
                        ' On Error Resume Next
                        '從Yahoo字典摘取第一組中文翻譯
                    
                         If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
                        '摘取KK音標
                        If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
                        .Open "get", iurl2 & rng, False
                        .send
                        '從DICT.TW 英漢字典擷取字義
                        If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
                    End With
             End If
    Next
End Sub

---

作者: brianhau    時間: 2015-12-9 14:43

請問
我想要自己來試試看
這段程式碼要貼在EXCEL的哪裡才能使用呢？

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)