VBA实现从下拉列表新建工作表，提取指定卫生局患者数据

• 给你的按钮绑定下面这个专门的提取数据宏，代替原来的工作表变更事件逻辑：

Sub ExtractHealthBureauData()
    Dim wsUser As Worksheet, wsData As Worksheet, wsNew As Worksheet
    Dim bureauID As String
    Dim lastRow As Long, i As Long, newRow As Long
    
    ' 指定工作表对象
    Set wsUser = ThisWorkbook.Worksheets("user")
    Set wsData = ThisWorkbook.Worksheets("data")
    
    ' 获取选中的卫生局编号
    bureauID = wsUser.Range("Q42").Value
    If bureauID = "" Then
        MsgBox "请先选择卫生局编号！", vbExclamation
        Exit Sub
    End If
    
    ' 检查是否已有同名工作表
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets(bureauID)
    On Error GoTo 0
    If Not wsNew Is Nothing Then
        MsgBox "已经存在名为「" & bureauID & "」的工作表了！", vbExclamation
        Exit Sub
    End If
    
    ' 新建并命名工作表
    Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    wsNew.Name = bureauID
    
    ' 复制表头到新表
    wsData.Rows(1).Copy Destination:=wsNew.Rows(1)
    newRow = 2 ' 新表从第二行开始写入数据
    
    ' 遍历data表提取对应卫生局的数据
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row ' 假设卫生局编号在A列，按需修改列标识
    For i = 2 To lastRow
        If wsData.Cells(i, "A").Value = bureauID Then ' 这里的列标识要和实际对应
            wsData.Rows(i).Copy Destination:=wsNew.Rows(newRow)
            newRow = newRow + 1
        End If
    Next i
    
    ' 自动调整新表列宽
    wsNew.Columns.AutoFit
    
    MsgBox "数据提取完成，已创建工作表：" & bureauID, vbInformation
End Sub

• 绑定宏的操作：右键点击你的按钮，选择「指定宏」，在列表里选中ExtractHealthBureauData确定即可。

• 关键调整说明：

  • 代码里假设卫生局编号在data表的A列、表头在第一行，你要根据自己的表格结构修改列标识（比如把"A"改成实际的列字母/数字）。
  • 如果只需要复制数据不要格式，可以把wsData.Rows(i).Copy改成wsData.Rows(i).Copy后，加一行wsNew.Rows(newRow).PasteSpecial xlPasteValues，避免格式错乱。
  • 你原来的Worksheet_Change事件代码可以保留（如果需要那些插入行、隐藏工作表的功能），它和这个提取数据的宏互不干扰。

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