VBA代码误判不存在Date列问题求助

我编写了一段VBA代码，用于将单个工作表中的数据依据"Date"列的日期拆分到新工作簿的独立月度工作表中，但代码始终提示不存在Date列。已确认该列存在（无空格/隐藏字符、未合并单元格，尝试过文本和常规格式），仍无法解决问题。原代码如下：

Sub SplitDataByMonth()
    Dim wsMaster As Worksheet
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim lastRow As Long, lastCol As Long
    Dim currentRow As Long
    Dim monthName As String
    Dim targetRow As Long
    Dim dateCol As Long
    Dim destinationFilePath As String
    Dim sheetName As String
    Dim headerRow As Long
    Dim headerValue As String
    
    ' Set the source workbook
    Set wbSource = ThisWorkbook
    
    ' Define the sheet name
    sheetName = "Sheet1" ' Ensure this matches the actual tab name in Excel
    
    ' Check if the "Sheet1" sheet exists
    On Error Resume Next
    Set wsMaster = wbSource.Sheets(sheetName)
    On Error GoTo 0
    
    If wsMaster Is Nothing Then
        MsgBox "The sheet '" & sheetName & "' does not exist in the source workbook. Please check the sheet name.", vbCritical
        Exit Sub
    End If
    
    ' Define the header row (assume row 1 by default)
    headerRow = 1 ' Change this if your headers are in a different row
    
    ' Force VBA to read the header value as text
    headerValue = wsMaster.Range("C1").Value ' Explicitly reference cell C1
    
    ' Compare case-insensitively
    If UCase(headerValue) <> "DATE" Then
        MsgBox "The header in column C is: '" & headerValue & "'. It does not match 'Date'. Please check for extra spaces or hidden characters.", vbCritical
        Exit Sub
    End If
    
    ' Find the column containing the "Date" header
    On Error Resume Next
    dateCol = Application.Match("Date", wsMaster.Rows(headerRow), 0) ' Change "Date" to the exact header name
    On Error GoTo 0
    
    If dateCol = 0 Then
        MsgBox "The 'Date' column was not found in the Sheet1 sheet. Please check the header name.", vbCritical
        Exit Sub
    End If
    
    ' Define the destination workbook file path
    destinationFilePath = "C:\Users\<YourUsername>\Desktop\MonthlyData.xlsx" ' Change this to your desired file path
    
    ' Check if the destination workbook exists, and open it if it does
    On Error Resume Next
    Set wbDestination = Workbooks.Open(destinationFilePath)
    On Error GoTo 0
    
    ' If the destination workbook does not exist, create it
    If wbDestination Is Nothing Then
        Set wbDestination = Workbooks.Add
        On Error Resume Next
        wbDestination.SaveAs destinationFilePath
        On Error GoTo 0
        If Err.Number <> 0 Then
            MsgBox "Unable to save the destination workbook. Please check the file path: " & destinationFilePath, vbCritical
            Exit Sub
        End If
        MsgBox "Destination workbook created at: " & destinationFilePath, vbInformation
    End If
    
    ' Find the last row and column in the Sheet1 sheet
    lastRow = wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row
    lastCol = wsMaster.Cells(1, wsMaster.Columns.Count).End(xlToLeft).Column
    
    ' Loop through each row in the Sheet1 sheet (starting from row 2)
    For currentRow = 2 To lastRow
        ' Get the month name from the Date column
        If IsDate(wsMaster.Cells(currentRow, dateCol).Value) Then
            monthName = Format(wsMaster.Cells(currentRow, dateCol).Value, "mmmm") ' Full month name
            
            ' Check if the target sheet for the month exists in the destination workbook, and create it if not
            On Error Resume Next
            Set wsTarget = wbDestination.Sheets(monthName)
            If wsTarget Is Nothing Then
                Set wsTarget = wbDestination.Sheets.Add(After:=wbDestination.Sheets(wbDestination.Sheets.Count))
                wsTarget.Name = monthName
                ' Copy the header row from the Sheet1 sheet to the new sheet
                wsMaster.Rows(headerRow).Copy Destination:=wsTarget.Rows(1)
            End If
            On Error GoTo 0
            
            ' Find the next empty row in the target sheet
            targetRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row + 1
            
            ' Copy the current row from the Sheet1 sheet to the target sheet
            wsMaster.Rows(currentRow).Copy Destination:=wsTarget.Rows(targetRow)
        End If
    Next currentRow
    
    ' Save and close the destination workbook
    On Error Resume Next
    wbDestination.Save
    If Err.Number <> 0 Then
        MsgBox "Unable to save the destination workbook. Please check the file path or permissions.", vbCritical
        Exit Sub
    End If
    MsgBox "Data has been successfully split into monthly sheets in the destination workbook!", vbInformation
    
    ' Optionally close the destination workbook
    ' wbDestination.Close SaveChanges:=True
End Sub

问题分析及修复方案 #

问题核心是Application.Match默认区分大小写，若表头实际为"DATE"、"date"等大小写变体，会导致匹配失败；同时代码中硬编码判断C1单元格的逻辑冗余且不灵活，若Date列不在C列会误判。

修复后的代码

Sub SplitDataByMonth()
    Dim wsMaster As Worksheet
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim lastRow As Long, lastCol As Long
    Dim currentRow As Long
    Dim monthName As String
    Dim targetRow As Long
    Dim dateCol As Variant ' 改为Variant类型，适配Match返回的错误值
    Dim destinationFilePath As String
    Dim sheetName As String
    Dim headerRow As Long
    
    ' 设置源工作簿
    Set wbSource = ThisWorkbook
    
    ' 定义工作表名称
    sheetName = "Sheet1" ' 确保与实际表名一致
    
    ' 检查Sheet1是否存在
    On Error Resume Next
    Set wsMaster = wbSource.Sheets(sheetName)
    On Error GoTo 0
    
    If wsMaster Is Nothing Then
        MsgBox "工作表'" & sheetName & "'不存在，请检查表名。", vbCritical
        Exit Sub
    End If
    
    ' 定义表头行（默认第1行）
    headerRow = 1 ' 若表头不在第1行，修改此处
    
    ' 不区分大小写查找Date列，统一转大写匹配
    On Error Resume Next
    dateCol = Application.Match(UCase("DATE"), UCase(wsMaster.Rows(headerRow)), 0)
    On Error GoTo 0
    
    ' 检查是否找到Date列
    If IsError(dateCol) Then
        MsgBox "未找到'Date'列，请检查表头名称。", vbCritical
        Exit Sub
    End If
    
    ' 定义目标工作簿路径
    destinationFilePath = "C:\Users\<YourUsername>\Desktop\MonthlyData.xlsx" ' 修改为你的目标路径
    
    ' 检查目标工作簿是否存在，存在则打开
    On Error Resume Next
    Set wbDestination = Workbooks.Open(destinationFilePath)
    On Error GoTo 0
    
    ' 若目标工作簿不存在则创建
    If wbDestination Is Nothing Then
        Set wbDestination = Workbooks.Add
        On Error Resume Next
        wbDestination.SaveAs destinationFilePath
        On Error GoTo 0
        If Err.Number <> 0 Then
            MsgBox "无法保存目标工作簿，请检查路径：" & destinationFilePath, vbCritical
            Exit Sub
        End If
        MsgBox "目标工作簿已创建：" & destinationFilePath, vbInformation
    End If
    
    ' 获取源表最后一行和最后一列
    lastRow = wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row
    lastCol = wsMaster.Cells(1, wsMaster.Columns.Count).End(xlToLeft).Column
    
    ' 遍历数据行（从第2行开始）
    For currentRow = 2 To lastRow
        ' 判断当前行日期是否有效
        If IsDate(wsMaster.Cells(currentRow, dateCol).Value) Then
            monthName = Format(wsMaster.Cells(currentRow, dateCol).Value, "mmmm") ' 获取完整月份名称
            
            ' 检查目标工作表是否存在，不存在则创建
            On Error Resume Next
            Set wsTarget = wbDestination.Sheets(monthName)
            If wsTarget Is Nothing Then
                Set wsTarget = wbDestination.Sheets.Add(After:=wbDestination.Sheets(wbDestination.Sheets.Count))
                wsTarget.Name = monthName
                ' 复制表头到新工作表
                wsMaster.Rows(headerRow).Copy Destination:=wsTarget.Rows(1)
            End If
            On Error GoTo 0
            
            ' 获取目标表下一个空行
            targetRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row + 1
            
            ' 复制当前行数据到目标表
            wsMaster.Rows(currentRow).Copy Destination:=wsTarget.Rows(targetRow)
        End If
    Next currentRow
    
    ' 保存目标工作簿
    On Error Resume Next
    wbDestination.Save
    If Err.Number <> 0 Then
        MsgBox "无法保存目标工作簿，请检查路径或权限。", vbCritical
        Exit Sub
    End If
    MsgBox "数据已成功拆分到月度工作表！", vbInformation
    
    ' 可选：关闭目标工作簿
    ' wbDestination.Close SaveChanges:=True
End Sub

关键修改点

1. 将dateCol类型改为Variant，避免Match返回错误值时赋值失败。
2. 使用UCase统一转换表头和查找值为大写，实现不区分大小写匹配，解决大小写不一致导致的查找失败问题。
3. 移除硬编码判断C1单元格的冗余逻辑，改为动态查找Date列，适配表头在任意列的场景。
4. 用IsError(dateCol)替代dateCol = 0判断是否找到列，更准确捕获Match的错误返回。

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