EXCEL VBA 单词批量翻译

可用于背诵单词，业务需要等等。

将A列所有的单词全部翻译，并且将结果翻译到B列上

代码：

    Dim ws As Worksheet  
    Dim lastRow As Long  
    Dim i As Long  
    Dim url As String  
    Dim xhr As Object  
    Dim query As String  
    Dim result As String  
    Dim explainText As String  
    Dim startPos As Long  
    Dim endPos As Long  
      
    ' 设置工作表  
    Set ws = ThisWorkbook.Sheets("Sheet1")  
      
    ' 找到A列的最后一行  
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row  
      
    ' 遍历A列的所有单元格  
    For i = 1 To lastRow  
        ' 从A列的当前单元格获取查询值  
        query = ws.Cells(i, "A").Value  
          
        ' 如果单元格不为空且B列对应单元格为空，则继续处理  
        If Len(Trim(query)) > 0 And Len(Trim(ws.Cells(i, "B").Value)) = 0 Then  
            ' 构建请求的URL  
            url = "http://dict.youdao.com/suggest?q=" & EncodeURL(query) & "&num=1&doctype=json"  
              
            ' 创建一个新的XMLHTTP对象  
            Set xhr = CreateObject("MSXML2.XMLHTTP")  
              
            ' 发送GET请求  
            With xhr  
                .Open "GET", url, False  
                .send  
                ' 等待请求完成  
                While .readyState <> 4 Or .Status <> 200  
                    DoEvents  
                Wend  
                ' 获取响应文本  
                result = .responseText  
            End With  
              
            ' 清理  
            Set xhr = Nothing  
              
            ' 假设JSON格式固定，手动解析以获取explain的值  
            startPos = InStr(1, result, """explain"":""") + Len("""explain"":")  
            endPos = InStr(startPos, result, """,")  
            If startPos > 0 And endPos > startPos Then  
                explainText = Mid(result, startPos, endPos - startPos)  
                ' 去除可能的引号  
                explainText = Replace(explainText, """", "")  
                  
                ' 将解释文本赋值到右边一格的单元格中  
                ws.Cells(i, "B").Value = explainText  
            Else  
                ' 如果未找到，显示错误消息（但这里我们只在VBA中记录，不弹出MsgBox）  
                ' MsgBox "无法找到explain属性的值"  
                ws.Cells(i, "B").Value = "无法找到结果"  
            End If  
        End If  
    Next i  
End Sub  
  
' URL编码的辅助函数（简单示例，只处理空格）  
Function EncodeURL(ByVal strText As String) As String  
    Dim strBuffer As String  
    strBuffer = Replace(strText, " ", "+") ' 仅处理空格  
    EncodeURL = strBuffer  
End Function

用法：函数名自行拟定，绘画activate按钮控件，在代码修改所对应的列。