VBA中AllowEditRanges循环工作表失效及动态范围问题求助

一、修复运行时错误13（类型不匹配） #

触发错误的核心原因有两个：

1. tabNames是从单元格区域读取的二维数组，直接用For Each遍历无法正确获取工作表名；同时未校验工作表是否存在，若列表中有无效名称会直接报错
2. AllowEditRanges.Add的Range参数要求传入Range对象，但原代码传入的是字符串，导致类型不匹配

修正后的完整代码 #

Sub alloweditrangesmacro()
    Dim wb1 As Workbook
    Dim lastrow As Long
    Dim tabNames As Variant
    Dim i As Long
    Dim wsName As String
    Dim ws As Worksheet
    
    Set wb1 = ThisWorkbook
        
    lastrow = wb1.Sheets("Start Here").Cells(Rows.Count, "R").End(xlUp).Row
    tabNames = wb1.Sheets("Start Here").Range("R2:R" & lastrow).Value
    
    ' 遍历二维数组中的工作表名（单列数组结构为(1到n, 1)）
    For i = LBound(tabNames, 1) To UBound(tabNames, 1)
        wsName = tabNames(i, 1)
        
        ' 校验工作表是否存在，避免无效名称触发错误
        On Error Resume Next
        Set ws = wb1.Sheets(wsName)
        On Error GoTo 0
        
        If ws Is Nothing Then
            MsgBox "工作表[" & wsName & "]不存在，已跳过", vbExclamation
            Set ws = Nothing
            Continue For
        End If
        
        ' 关键修正：传入Range对象而非字符串
        ws.Protection.AllowEditRanges.Add Title:="Budget1", Range:=ws.Range("B9,B12:B26,B32:B38,B42:B58,B62:B70,B73:B76,B83:B91")
        ws.Protection.AllowEditRanges.Add Title:="Budget2", Range:=ws.Range("I9,I12:I26,I32:I38,I42:I58,I62:I70,I73:I76,I83:I91")
        ws.Protection.AllowEditRanges.Add Title:="Prior1", Range:=ws.Range("D9,D12:D26,D32:D38,D42:D58,D62:D70,D73:D76,D83:D91")
        ws.Protection.AllowEditRanges.Add Title:="Prior2", Range:=ws.Range("K9,K12:K26,K32:K38,K42:K58,K62:K70,K73:K76,K83:K91")
        
        ws.Protect
        Set ws = Nothing
    Next i
End Sub

二、动态生成可编辑范围（跳过空白与公式单元格） #

可以通过辅助函数自动筛选指定列中9-101行内非空且非公式的单元格，合并为可编辑范围：

辅助函数代码 #

Function GetEditableRange(ws As Worksheet, colLetter As String, startRow As Long, endRow As Long) As Range
    Dim targetColRange As Range
    Dim cell As Range
    Dim combinedRange As Range
    
    Set targetColRange = ws.Range(colLetter & startRow & ":" & colLetter & endRow)
    
    For Each cell In targetColRange
        ' 筛选条件：单元格非空 且 不包含公式
        If Not IsEmpty(cell.Value) And Not cell.HasFormula Then
            If combinedRange Is Nothing Then
                Set combinedRange = cell
            Else
                Set combinedRange = Union(combinedRange, cell)
            End If
        End If
    Next cell
    
    Set GetEditableRange = combinedRange
End Function

在主代码中调用辅助函数 #

替换原循环内的可编辑区域添加逻辑，改为动态生成范围：

' 在循环内获取到有效ws对象后：
Dim budget1Rng As Range, budget2Rng As Range
Dim prior1Rng As Range, prior2Rng As Range

' 动态生成各列的可编辑范围
Set budget1Rng = GetEditableRange(ws, "B", 9, 101)
Set budget2Rng = GetEditableRange(ws, "I", 9, 101)
Set prior1Rng = GetEditableRange(ws, "D", 9, 101)
Set prior2Rng = GetEditableRange(ws, "K", 9, 101)

' 仅当存在符合条件的单元格时，添加可编辑区域
If Not budget1Rng Is Nothing Then
    ws.Protection.AllowEditRanges.Add Title:="Budget1", Range:=budget1Rng
End If
If Not budget2Rng Is Nothing Then
    ws.Protection.AllowEditRanges.Add Title:="Budget2", Range:=budget2Rng
End If
If Not prior1Rng Is Nothing Then
    ws.Protection.AllowEditRanges.Add Title:="Prior1", Range:=prior1Rng
End If
If Not prior2Rng Is Nothing Then
    ws.Protection.AllowEditRanges.Add Title:="Prior2", Range:=prior2Rng
End If

ws.Protect

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