请求修改VBA代码：按用户指定条件拆分Data工作表数据

问题背景 #

你当前的VBA代码能把Data工作表的所有数据按机会名称拆分到对应工作表，但需要调整为按用户输入的特定机会名称筛选复制，具体需求如下：

• 用户在Diagram工作表的W11单元格输入机会名称
• 点击Split Data按钮后，自动创建/覆盖名为Opportunity的工作表
• 仅复制Data表中匹配用户输入的行的A-D列数据
• 支持重复点击按钮覆盖旧数据，且能自动识别Data表新增的最后一行数据

你的原始代码 #

Private Sub CommandButton2_Click()
 Const col = "A"
 Const header_row = 1
 Const starting_row = 2
 Dim source_sheet As Worksheet
 Dim destination_sheet As Worksheet
 Dim source_row As Long
 Dim last_row As Long
 Dim destination_row As Long
 Dim Opp As String
 Set source_sheet = Workbooks("CobhamMappingTool").Worksheets("Data")
 last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
 For source_row = starting_row To last_row
 Opp = source_sheet.Cells(source_row, col).Value
 Set destination_sheet = Nothing
 On Error Resume Next
 Set destination_sheet = Worksheets(Opp)
 On Error GoTo 0
 If destination_sheet Is Nothing Then
 Set destination_sheet=Worksheets.Add(after:=Worksheets(Worksheets.Count))
 destination_sheet.Name = Opp
 source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
 End If
 destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
 source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
 Next source_row
End Sub

修改后的适配代码 #

下面是完全满足你需求的代码，我添加了注释方便你理解逻辑：

Private Sub CommandButton2_Click()
    Const OPPORTUNITY_COL As String = "A" ' 机会名称所在的列（对应你的A列）
    Const HEADER_ROW As Long = 1          ' 表头所在行
    Const STARTING_ROW As Long = 2        ' 数据起始行
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim userInputOpp As String
    Dim lastSourceRow As Long
    Dim sourceRow As Long
    Dim targetRow As Long
    
    ' 1. 获取用户输入并校验是否为空
    userInputOpp = Trim(ThisWorkbook.Worksheets("Diagram").Range("W11").Value)
    If userInputOpp = "" Then
        MsgBox "请先在Diagram工作表的W11单元格输入要筛选的机会名称哦！", vbExclamation
        Exit Sub
    End If
    
    ' 2. 定位源工作表并自动获取最后一行数据行号
    Set sourceSheet = ThisWorkbook.Worksheets("Data")
    lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, OPPORTUNITY_COL).End(xlUp).Row
    
    ' 3. 处理目标工作表：存在则清空旧数据，不存在则新建
    On Error Resume Next
    Set targetSheet = ThisWorkbook.Worksheets("Opportunity")
    On Error GoTo 0
    
    If Not targetSheet Is Nothing Then
        ' 保留表头，清空表头以下的所有旧数据
        targetSheet.Rows(STARTING_ROW & ":" & targetSheet.Rows.Count).ClearContents
    Else
        ' 新建工作表并命名，同时复制源表的A-D列表头
        Set targetSheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        targetSheet.Name = "Opportunity"
        sourceSheet.Range("A" & HEADER_ROW & ":D" & HEADER_ROW).Copy Destination:=targetSheet.Range("A" & HEADER_ROW)
    End If
    
    ' 4. 遍历源表数据，筛选匹配项并复制A-D列到目标表
    targetRow = STARTING_ROW ' 目标表从第二行开始写入数据
    For sourceRow = STARTING_ROW To lastSourceRow
        ' 去掉前后空格实现精准匹配
        If Trim(sourceSheet.Cells(sourceRow, OPPORTUNITY_COL).Value) = userInputOpp Then
            ' 仅复制A-D列，而非整行
            sourceSheet.Range("A" & sourceRow & ":D" & sourceRow).Copy Destination:=targetSheet.Range("A" & targetRow)
            targetRow = targetRow + 1 ' 写完一行后目标行下移
        End If
    Next sourceRow
    
    ' 操作完成提示，告知复制的数据行数
    MsgBox "搞定啦！一共复制了 " & (targetRow - STARTING_ROW) & " 行匹配的数据到Opportunity工作表。", vbInformation
End Sub

关键改进点说明 #

• 输入校验：先检查用户是否输入内容，避免无效操作；
• 目标表优化：重复点击时不删除工作表，仅清空旧数据，保留表头，操作更高效；
• 精准复制：只复制匹配行的A-D列，完全符合你的需求；
• 自适应数据范围：自动识别Data表的最后一行，不管数据新增多少都能覆盖；
• 友好提示：操作完成后弹出提示，直观告知用户复制的行数。

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