如何通过VBA宏按钮结合Google Sheets API自动上传Excel数据？

错误原因 #

你遇到的sub or function not defined错误，是因为原代码调用了cjobject、putStuffToSheets、getGoogled这些未定义的自定义对象和函数，属于依赖缺失问题。

前置准备 #

• 确保已在Google Cloud Console中启用Google Sheets API，并持有有效的Client ID、Client Secret
• 在Excel VBA编辑器中添加两个引用（工具→引用）：
  • Microsoft Scripting Runtime
  • Microsoft XML, v6.0

完整可运行代码 #

Option Explicit

' 替换为你的Google服务信息
Const CLIENT_ID As String = "你的ClientID"
Const CLIENT_SECRET As String = "你的ClientSecret"
Const SHEET_ID As String = "你的SheetID"

' OAuth2授权相关常量
Const AUTH_URL As String = "https://accounts.google.com/o/oauth2/v2/auth"
Const TOKEN_URL As String = "https://oauth2.googleapis.com/token"
Const SCOPE As String = "https://www.googleapis.com/auth/spreadsheets"

' 存储访问令牌
Private AccessToken As String

Public Sub UploadExcelDataToGoogleSheets()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim dataRange As Range
    Dim jsonPayload As String
    Dim apiUrl As String
    
    ' 定位当前活动工作表的数据范围
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
    
    ' 获取/刷新访问令牌
    If Not GetAccessToken() Then
        MsgBox "获取访问令牌失败，无法上传数据", vbCritical
        Exit Sub
    End If
    
    ' 构建API请求地址（替换"Sheet1"为你的目标工作表名称）
    apiUrl = "https://sheets.googleapis.com/v4/spreadsheets/" & SHEET_ID & "/values/Sheet1!A1:" & ColLetter(lastCol) & lastRow & "?valueInputOption=RAW"
    
    ' 转换Excel数据为JSON格式
    jsonPayload = ConvertRangeToJson(dataRange)
    
    ' 发送上传请求
    If SendPutRequest(apiUrl, jsonPayload) Then
        MsgBox "数据上传成功！", vbInformation
    Else
        MsgBox "数据上传失败", vbCritical
    End If
End Sub

Private Function GetAccessToken() As Boolean
    Dim tokenCache As String
    Dim tokenExpiry As Date
    Dim jsonResponse As String
    Dim jsonObj As Object
    
    ' 读取缓存的令牌（避免重复授权）
    tokenCache = GetSetting("ExcelGoogleSheets", "Auth", "AccessToken", "")
    tokenExpiry = CDate(GetSetting("ExcelGoogleSheets", "Auth", "TokenExpiry", "1900-01-01"))
    
    ' 令牌未过期则直接使用
    If tokenCache <> "" And Now() < tokenExpiry Then
        AccessToken = tokenCache
        GetAccessToken = True
        Exit Function
    End If
    
    ' 生成授权URL并打开浏览器引导用户授权
    Dim authRequestUrl As String
    authRequestUrl = AUTH_URL & "?client_id=" & CLIENT_ID & _
                     "&redirect_uri=urn:ietf:wg:oauth:2.0:oob" & _
                     "&scope=" & SCOPE & _
                     "&response_type=code"
    
    Shell "explorer.exe """ & authRequestUrl & """", vbNormalFocus
    Dim authCode As String
    authCode = InputBox("请输入Google授权页面显示的授权码：")
    
    If authCode = "" Then
        GetAccessToken = False
        Exit Function
    End If
    
    ' 用授权码交换访问令牌
    Dim postData As String
    postData = "code=" & authCode & _
               "&client_id=" & CLIENT_ID & _
               "&client_secret=" & CLIENT_SECRET & _
               "&redirect_uri=urn:ietf:wg:oauth:2.0:oob" & _
               "&grant_type=authorization_code"
    
    jsonResponse = SendPostRequest(TOKEN_URL, postData)
    
    ' 解析JSON响应
    Set jsonObj = ParseJson(jsonResponse)
    
    If Not jsonObj Is Nothing Then
        AccessToken = jsonObj("access_token")
        Dim expiresIn As Integer
        expiresIn = jsonObj("expires_in")
        tokenExpiry = Now() + TimeSerial(0, 0, expiresIn)
        
        ' 缓存令牌到注册表
        SaveSetting "ExcelGoogleSheets", "Auth", "AccessToken", AccessToken
        SaveSetting "ExcelGoogleSheets", "Auth", "TokenExpiry", CStr(tokenExpiry)
        
        GetAccessToken = True
    Else
        GetAccessToken = False
    End If
End Function

Private Function SendPostRequest(url As String, postData As String) As String
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    
    xmlHttp.Open "POST", url, False
    xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlHttp.send postData
    
    SendPostRequest = xmlHttp.responseText
End Function

Private Function SendPutRequest(url As String, jsonPayload As String) As Boolean
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    
    On Error GoTo ErrorHandler
    xmlHttp.Open "PUT", url, False
    xmlHttp.setRequestHeader "Authorization", "Bearer " & AccessToken
    xmlHttp.setRequestHeader "Content-Type", "application/json"
    xmlHttp.send jsonPayload
    
    SendPutRequest = (xmlHttp.Status = 200)
    
    Exit Function
ErrorHandler:
    SendPutRequest = False
End Function

Private Function ConvertRangeToJson(rng As Range) As String
    Dim row As Range
    Dim cell As Range
    Dim jsonArray As String
    Dim rowArray As String
    
    jsonArray = "{""values"": ["
    
    For Each row In rng.Rows
        rowArray = "["
        For Each cell In row.Cells
            rowArray = rowArray & """" & Replace(cell.Value, """", "\""") & """" & ","
        Next cell
        rowArray = Left(rowArray, Len(rowArray) - 1) & "],"
        jsonArray = jsonArray & rowArray
    Next row
    
    jsonArray = Left(jsonArray, Len(jsonArray) - 1) & "]}"
    ConvertRangeToJson = jsonArray
End Function

Private Function ColLetter(colIndex As Integer) As String
    Dim div As Integer
    Dim modResult As Integer
    ColLetter = ""
    
    Do While colIndex > 0
        div = (colIndex - 1) \ 26
        modResult = (colIndex - 1) Mod 26
        ColLetter = Chr(65 + modResult) & ColLetter
        colIndex = div
    Loop
End Function

Private Function ParseJson(jsonText As String) As Object
    Dim sc As ScriptControl
    Set sc = CreateObject("ScriptControl")
    sc.Language = "JScript"
    
    On Error Resume Next
    Set ParseJson = sc.Eval("(" & jsonText & ")")
    On Error GoTo 0
End Function

使用步骤 #

1. 替换代码顶部的CLIENT_ID、CLIENT_SECRET、SHEET_ID为你自己的信息
2. 在Excel中插入按钮（开发工具→插入→按钮），将按钮关联的宏设置为UploadExcelDataToGoogleSheets
3. 首次运行时，会自动打开Google授权页面，复制授权码到弹出的输入框完成授权
4. 后续运行将自动使用缓存的令牌，无需重复授权

常见问题排查 #

• 若出现“找不到ScriptControl”错误：需启用Microsoft Script Control组件，或改用其他JSON解析方式
• 若API请求失败：检查SheetID是否正确、目标工作表名称是否与代码中的Sheet1一致、Google Sheets API是否已启用

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