VBA中使用InputBox选择范围时出现Error 400错误求助

我是VBA新手，尝试通过选择标注为PL的单元格来申请多天休假时，触发了Error 400错误，无法继续执行代码。即便只选择包含PL的单元格，错误依然出现。以下是我使用的代码：

Sub CreateLeaveApplication()

    ' Declare variables
    Dim ws As Worksheet
    Dim selectedRange As String ' String to store user selection (can contain dollar signs)
    Dim selectedCells As Range ' Range object to hold selected cells
    Dim cell As Range
    Dim empName As String
    Dim leaveDetails As String
    Dim outlookApp As Object ' Optional for email (requires references)
    Dim outlookMail As Object ' Optional for email (requires references)
    Dim empRow As Integer
    Dim startDate As String
    Dim endDate As String
    Dim dates As Collection
    Dim temp As Variant
    Dim i As Integer, j As Integer
    Dim empLeaveData As Object
    Dim col As Integer

    ' Set the worksheet (adjust the sheet name if necessary)
    Set ws = ThisWorkbook.Sheets("Leave Planning 2024 - abcd")

    ' Prompt the user to select a range with PL cells (forces user to select a range)
    selectedRange = Application.InputBox("Select the cells with PL (e.g., A1:C10)", Type:=2) ' Type:=2 for xlRangeConstant

    ' Check if a valid range is selected
    If selectedRange = "" Then ' Empty string indicates no selection
        MsgBox "No range selected. Please select a range containing 'PL' cells.", vbExclamation
        Exit Sub ' Exit the subroutine if no range is selected
    End If

    ' Clean the captured string (remove dollar signs if present)
    selectedRange = Replace(selectedRange, "$", "") ' Remove dollar signs before conversion

    ' Convert the cleaned string to range object
    Set selectedCells = ws.Range(selectedRange)

    ' Validate the selection (optional)
    ' You can add code here to check if the selected range is within a specific sheet area

    ' Initialize leave details string and collections
    leaveDetails = ""
    Set dates = New Collection
    Set empLeaveData = CreateObject("Scripting.Dictionary")

    ' Loop through each cell in the selected range
    For Each cell In selectedCells
        If cell.Value = "PL" Then
            ' Find employee name based on row of selected cell
            empRow = cell.Row
            empName = ws.Cells(empRow, 3).Value ' Assuming employee name is in column C

            ' Get the date (column header) based on selected cell's column
            col = cell.Column
            If Not empLeaveData.Exists(empName) Then
                Set empLeaveData(empName) = CreateObject("Scripting.Dictionary")
            End If
            If Not empLeaveData(empName).Exists(ws.Cells(1, col).Value) Then
                empLeaveData(empName).Add ws.Cells(1, col).Value, ws.Cells(1, col).Value
            End If
        End If
    Next cell

    ' Process leave details for each employee
    ' ... rest of your code for processing and displaying leave details ...

End Sub

可能的错误原因及修复方案 #

• InputBox类型错误：原代码使用Type:=2（对应xlRangeConstant），这会返回单元格的值而非范围引用，后续转字符串再转Range的操作容易出错。正确做法是使用Type:=8直接返回Range对象：

  ' 替换原InputBox相关代码
  Set selectedCells = Application.InputBox("Select the cells with PL (e.g., A1:C10)", Type:=8)
  
  ' 修改取消选择的判断逻辑
  If selectedCells Is Nothing Then
      MsgBox "No range selected. Please select a range containing 'PL' cells.", vbExclamation
      Exit Sub
  End If
  

  这样无需处理字符串和$符号，直接获取用户选择的范围，避免转换错误。

• 工作表范围不匹配：如果用户选择的单元格不在Leave Planning 2024 - abcd工作表中，ws.Range(selectedRange)会触发错误。使用Type:=8获取Range后，可以添加校验确保范围属于目标工作表：

  If selectedCells.Parent.Name <> ws.Name Then
      MsgBox "Please select cells from the 'Leave Planning 2024 - abcd' sheet.", vbExclamation
      Exit Sub
  End If
  

• 无效单元格值处理：循环检查单元格值时，若单元格为空或不是文本类型，cell.Value = "PL"可能引发隐性错误。可以添加类型判断：

  If Not IsEmpty(cell.Value) And cell.Value = "PL" Then
      ' 原逻辑代码
  End If
  

修改后的完整代码示例 #

Sub CreateLeaveApplication()

    ' Declare variables
    Dim ws As Worksheet
    Dim selectedCells As Range ' Range object to hold selected cells
    Dim cell As Range
    Dim empName As String
    Dim leaveDetails As String
    Dim outlookApp As Object ' Optional for email (requires references)
    Dim outlookMail As Object ' Optional for email (requires references)
    Dim empRow As Integer
    Dim startDate As String
    Dim endDate As String
    Dim dates As Collection
    Dim temp As Variant
    Dim i As Integer, j As Integer
    Dim empLeaveData As Object
    Dim col As Integer

    ' Set the worksheet (adjust the sheet name if necessary)
    Set ws = ThisWorkbook.Sheets("Leave Planning 2024 - abcd")

    ' Prompt the user to select a range with PL cells
    Set selectedCells = Application.InputBox("Select the cells with PL (e.g., A1:C10)", Type:=8)

    ' Check if a valid range is selected
    If selectedCells Is Nothing Then
        MsgBox "No range selected. Please select a range containing 'PL' cells.", vbExclamation
        Exit Sub
    End If

    ' Validate selection is on target sheet
    If selectedCells.Parent.Name <> ws.Name Then
        MsgBox "Please select cells from the 'Leave Planning 2024 - abcd' sheet.", vbExclamation
        Exit Sub
    End If

    ' Initialize leave details string and collections
    leaveDetails = ""
    Set dates = New Collection
    Set empLeaveData = CreateObject("Scripting.Dictionary")

    ' Loop through each cell in the selected range
    For Each cell In selectedCells
        If Not IsEmpty(cell.Value) And cell.Value = "PL" Then
            ' Find employee name based on row of selected cell
            empRow = cell.Row
            empName = ws.Cells(empRow, 3).Value ' Assuming employee name is in column C

            ' Get the date (column header) based on selected cell's column
            col = cell.Column
            If Not empLeaveData.Exists(empName) Then
                Set empLeaveData(empName) = CreateObject("Scripting.Dictionary")
            End If
            If Not empLeaveData(empName).Exists(ws.Cells(1, col).Value) Then
                empLeaveData(empName).Add ws.Cells(1, col).Value, ws.Cells(1, col).Value
            End If
        End If
    Next cell

    ' Process leave details for each employee
    ' ... rest of your code for processing and displaying leave details ...

End Sub

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