按日期拆分数据至独立工作表的VBA代码问题求助

首先，咱们先梳理下你原代码里的几个核心问题：

• results是从单元格读取的数值数组，不能直接调用.Paste方法，数组没有这个属性
• 循环逻辑只处理了日期发生变化的节点，会漏掉第一个日期段和最后一段数据
• 使用Activate/Select不仅效率低，还容易因工作表切换出现意外错误
• 直接用原始日期值作为工作表名可能包含非法字符（比如/），导致创建工作表失败
• 初始的Target范围定义有误，应该是从A5到AR列的最后一行，而不是固定到AR10

下面是修正并完善后的代码，我会在关键部分加注释说明：

Sub SplitDataByDate()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim startRow As Long
    Dim currentRow As Long
    Dim currentDate As Variant
    Dim sheetName As String
    
    ' 设置源工作表（这里用ActiveSheet，你也可以改成具体工作表名比如Sheets("数据源")）
    Set wsSource = ActiveSheet
    
    With wsSource
        ' 获取A列最后一行数据（从A5开始的有效数据行）
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ' 起始行设为5（你的数据从A5开始）
        startRow = 5
        ' 记录第一个日期
        currentDate = .Cells(startRow, "B").Value2
        
        ' 遍历所有数据行，+1是为了处理最后一段数据
        For currentRow = startRow + 1 To lastRow + 1
            ' 当遇到不同日期，或者遍历到最后一行时，处理当前日期的数据段
            If currentRow > lastRow Or .Cells(currentRow, "B").Value2 <> currentDate Then
                ' 格式化日期为合法的工作表名（避免/等非法字符）
                sheetName = Format(currentDate, "yyyy-mm-dd")
                
                ' 检查是否已存在同名工作表，避免报错
                On Error Resume Next
                Set wsNew = ThisWorkbook.Sheets(sheetName)
                On Error GoTo 0
                
                ' 如果不存在则新建工作表
                If wsNew Is Nothing Then
                    Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    wsNew.Name = sheetName
                End If
                
                ' 复制当前日期的数据段（如果要包含表头，把startRow改成startRow-1，假设表头在A4）
                .Range(.Cells(startRow, "A"), .Cells(currentRow - 1, "AR")).Copy
                ' 粘贴到新工作表的A1位置
                wsNew.Cells(1, "A").PasteSpecial xlPasteAll
                
                ' 重置起始行和当前日期
                startRow = currentRow
                If currentRow <= lastRow Then
                    currentDate = .Cells(currentRow, "B").Value2
                End If
                
                ' 释放剪贴板（避免弹窗提示）
                Application.CutCopyMode = False
            End If
        Next currentRow
    End With
    
    MsgBox "数据拆分完成！", vbInformation
End Sub

关键改进点说明： #

• 避免数组操作陷阱：直接操作单元格Range进行复制，更直观且不易出错
• 完整处理所有数据段：通过遍历到最后一行+1的方式，确保最后一段数据也能被处理
• 合法工作表名：用Format(currentDate, "yyyy-mm-dd")把日期转成无非法字符的名称
• 防重复创建工作表：先检查是否已有同名表，避免重复创建导致报错
• 高效无切换操作：全程不使用Activate/Select，直接通过工作表对象操作，运行更稳定快速
• 可选表头复制：如果你的数据表头在A4行，只需要把复制范围的startRow改成startRow-1即可

使用注意事项： #

1. 确保你的日期数据在B列（代码里是.Cells(currentRow, "B")，如果列不同可以修改）
2. 数据从A5开始（如果起始行不同，修改startRow的值即可）
3. 如果不需要保留格式，也可以用值传递的方式，比复制粘贴更快：

   wsNew.Cells(1,"A").Resize(currentRow-startRow, 44).Value = .Range(.Cells(startRow,"A"), .Cells(currentRow-1,"AR")).Value
   

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