如何实现Excel VBA表单文本框数据提交至Google Sheet并逐行追加

我之前刚好做过一模一样的需求，踩了不少坑，给你整理一套亲测可行的方案！

一、前期准备工作（必须先搞定！） #

要让VBA能访问你的Google Sheet，得先完成Google端的配置：

• 创建好目标Google Sheet，记下它的文档ID（就是URL里d/后面到/edit之前的那串长字符）
• 开启Google Sheets API：去Google Cloud控制台新建项目，搜索启用「Sheets API」；然后创建服务账号，下载JSON密钥文件，把密钥里的邮箱地址添加到你的Google Sheet共享列表，给编辑权限
• 在Excel里加必要的引用：按Alt+F11打开VBA编辑器，点「工具→引用」，勾选Microsoft Scripting Runtime和Microsoft XML, v6.0（选你电脑上有的最高版本就行）

二、VBA代码实现（直接抄改就能用） #

假设你的表单有两个文本框（TextBox1、TextBox2）和一个提交按钮CommandButton1，代码分几部分写：

1. 配置参数（先替换成你自己的信息） #

Private Const GOOGLE_SHEET_ID As String = "你的Google Sheet文档ID"
Private Const SERVICE_ACCOUNT_EMAIL As String = "服务账号邮箱@xxx.iam.gserviceaccount.com"
' 注意：私钥要去掉首尾的-----BEGIN/END PRIVATE KEY-----，把换行替换成\n
Private Const PRIVATE_KEY As String = "你的服务账号私钥内容"

2. 提交按钮的点击事件 #

Private Sub CommandButton1_Click()
    ' 获取文本框内容
    Dim input1 As String, input2 As String
    input1 = Me.TextBox1.Value
    input2 = Me.TextBox2.Value
    
    ' 简单的输入验证（可选，按需调整）
    If input1 = "" Or input2 = "" Then
        MsgBox "请填写完整信息再提交！", vbExclamation
        Exit Sub
    End If
    
    ' 调用追加数据的函数
    Dim isSuccess As Boolean
    isSuccess = AppendDataToSheet(input1, input2)
    
    ' 给用户反馈
    If isSuccess Then
        MsgBox "提交成功！", vbInformation
        ' 清空文本框，方便下一次输入
        Me.TextBox1.Value = ""
        Me.TextBox2.Value = ""
    Else
        MsgBox "提交失败，检查配置或看调试信息！", vbCritical
    End If
End Sub

3. 核心追加数据函数 #

Private Function AppendDataToSheet(data1 As String, data2 As String) As Boolean
    Dim xmlHttp As MSXML2.XMLHTTP60
    Dim jwtToken As String
    Dim jsonPayload As String
    
    ' 生成身份验证用的JWT令牌
    jwtToken = GenerateJWT()
    If jwtToken = "" Then
        AppendDataToSheet = False
        Exit Function
    End If
    
    ' 构造要提交的JSON数据（可扩展更多字段）
    jsonPayload = "{""values"": [[""" & data1 & """, """ & data2 & """]]}"
    
    ' 发送POST请求到Google Sheets API
    Set xmlHttp = New MSXML2.XMLHTTP60
    With xmlHttp
        .Open "POST", "https://sheets.googleapis.com/v4/spreadsheets/" & GOOGLE_SHEET_ID & "/values/Sheet1!A:B:append?valueInputOption=USER_ENTERED", False
        .setRequestHeader "Authorization", "Bearer " & jwtToken
        .setRequestHeader "Content-Type", "application/json"
        .send jsonPayload
        
        ' 检查响应状态
        If .Status = 200 Then
            AppendDataToSheet = True
        Else
            ' 调试用：看具体错误信息
            Debug.Print "错误响应：" & .responseText
            AppendDataToSheet = False
        End If
    End With
    Set xmlHttp = Nothing
End Function

4. 辅助函数（生成JWT和编码用） #

' 生成JWT令牌（身份验证核心）
Private Function GenerateJWT() As String
    Dim header As String, payload As String
    Dim encodedHeader As String, encodedPayload As String
    Dim signature As String
    
    ' 构造JWT头部
    header = "{""alg"":""RS256"",""typ"":""JWT""}"
    ' 构造JWT载荷：过期时间设为当前+1小时
    payload = "{""iss"":""" & SERVICE_ACCOUNT_EMAIL & """,""scope"":""https://www.googleapis.com/auth/spreadsheets"",""aud"":""https://oauth2.googleapis.com/token"",""exp"":" & Round(Now() * 86400 + 3600) & ",""iat"":" & Round(Now() * 86400) & "}"
    
    ' Base64URL编码头部和载荷
    encodedHeader = Base64UrlEncode(ConvertToUtf8Bytes(header))
    encodedPayload = Base64UrlEncode(ConvertToUtf8Bytes(payload))
    
    ' 生成签名
    Dim signInput As String
    signInput = encodedHeader & "." & encodedPayload
    signature = RSASign(signInput, PRIVATE_KEY)
    
    If signature = "" Then
        GenerateJWT = ""
    Else
        GenerateJWT = encodedHeader & "." & encodedPayload & "." & signature
    End If
End Function

' 字符串转UTF-8字节数组
Private Function ConvertToUtf8Bytes(text As String) As Byte()
    Dim utf8Stream As Object
    Set utf8Stream = CreateObject("ADODB.Stream")
    With utf8Stream
        .Charset = "UTF-8"
        .Open
        .WriteText text
        .Position = 0
        ConvertToUtf8Bytes = .Read
        .Close
    End With
    Set utf8Stream = Nothing
End Function

' Base64URL编码（替换标准Base64的特殊字符）
Private Function Base64UrlEncode(bytes() As Byte) As String
    Dim base64Text As String
    Dim xmlDoc As Object, node As Object
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    Set node = xmlDoc.createElement("b64")
    
    node.DataType = "bin.base64"
    node.nodeTypedValue = bytes
    base64Text = node.Text
    
    ' 转换为Base64URL格式
    base64Text = Replace(Replace(base64Text, "+", "-"), "/", "_")
    base64Text = Left(base64Text, Len(base64Text) - InStrRev(base64Text, "="))
    Base64UrlEncode = base64Text
End Function

' RSASign签名函数（需要勾选CAPICOM引用）
Private Function RSASign(inputText As String, privateKey As String) As String
    Dim cryptoCtx As Object, privKey As Object, signedData As Object
    Set cryptoCtx = CreateObject("CAPICOM.CryptographicContext")
    Set privKey = CreateObject("CAPICOM.PrivateKey")
    Set signedData = CreateObject("CAPICOM.SignedData")
    
    ' 还原私钥的PEM格式
    privateKey = "-----BEGIN PRIVATE KEY-----" & vbCrLf & privateKey & vbCrLf & "-----END PRIVATE KEY-----"
    privKey.Load privateKey, "" ' 服务账号密钥无密码
    
    signedData.Content = inputText
    RSASign = signedData.Sign(privKey, CAPICOM_ENCODE_BASE64)
    ' 转换为Base64URL格式
    RSASign = Replace(Replace(RSASign, "+", "-"), "/", "_")
    RSASign = Left(RSASign, Len(RSASign) - InStrRev(RSASign, "="))
    
    Set signedData = Nothing
    Set privKey = Nothing
    Set cryptoCtx = Nothing
End Function

三、关键注意事项 #

• 私钥处理：从JSON密钥里复制private_key内容，一定要去掉首尾的-----BEGIN PRIVATE KEY-----和-----END PRIVATE KEY-----，把换行替换成\n（或者在VBA里用vbCrLf拼接）
• Sheet范围：代码里的Sheet1!A:B要改成你实际的Sheet名称和列范围，比如你的Sheet叫「表单记录」，要存A到C列数据，就写成表单记录!A:C
• 权限问题：必须把服务账号邮箱添加到Google Sheet共享列表，给编辑权限，否则会报403权限错误
• 调试技巧：提交失败时，按Ctrl+G打开VBA立即窗口，看Debug.Print输出的错误信息，大部分是配置错误或者JWT生成问题

四、扩展小技巧 #

• 如果有更多文本框，只需要在AppendDataToSheet函数里扩展jsonPayload的数组，比如[[""" & data1 & """, """ & data2 & """, """ & data3 & """]]
• 可以加更复杂的输入验证，比如手机号格式、日期格式检查
• 要批量提交的话，把数据整理成二维数组再构造JSON即可

内容的提问来源于stack exchange，提问作者user11710401