利用Excel宏在新工作表粘贴指定卫生署的患者数据

需求说明 #

• 拥有按年龄、性别、卫生署（字段标识为sha）分类的患者数据表格
• sha为数字编号，对应不同地区：1=诺福克、萨福克和剑桥郡，2=贝德福德郡和赫特福德郡，总计28个编号
• 已实现创建新工作表的基础宏，需新增功能：仅将下拉框选中的特定卫生署患者数据复制到目标工作表
• 下拉框选中的卫生署名称存储在user工作表的M42单元格

现有基础代码 #

Option Explicit

Sub createsheet()

   Dim sName As String, ws As Worksheet
   sName = Sheets("user").Range("M42").Value
   
   ' 检查工作表是否已存在
   On Error Resume Next
   Set ws = Sheets(sName)
   On Error GoTo 0
   
   If ws Is Nothing Then
       ' 新建工作表
       Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
       ws.Name = sName
       MsgBox "Sheet created : " & ws.Name, vbInformation
   Else
       ' 工作表已存在提示
       MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
   End If
   
End Sub

修改后完整功能代码 #

Option Explicit

Sub CreateSheetAndCopyFilteredData()
    Dim targetSheetName As String, wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim targetShaNumber As String
    Dim lastSourceRow As Long, nextTargetRow As Long
    
    ' --------------------------
    ' 请根据实际情况修改以下参数
    ' --------------------------
    Const SOURCE_SHEET_NAME As String = "Data" ' 原始数据所在工作表名称
    Const SHA_COLUMN As String = "C" ' sha字段所在列（例如C列）
    ' --------------------------
    
    ' 绑定原始数据工作表
    Set wsSource = ThisWorkbook.Sheets(SOURCE_SHEET_NAME)
    
    ' 获取选中的卫生署名称
    targetSheetName = Sheets("user").Range("M42").Value
    
    ' 匹配卫生署名称对应的sha编号，请补充完整28个条目
    Select Case targetSheetName
        Case "诺福克、萨福克和剑桥郡"
            targetShaNumber = "1"
        Case "贝德福德郡和赫特福德郡"
            targetShaNumber = "2"
        ' 示例：补充其他地区
        ' Case "XX地区"
        '     targetShaNumber = "X"
    End Select
    
    ' 检查目标工作表是否存在
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0
    
    If wsTarget Is Nothing Then
        ' 创建新工作表并复制表头
        Set wsTarget = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsTarget.Name = targetSheetName
        wsSource.Rows(1).Copy Destination:=wsTarget.Rows(1)
        MsgBox "已创建工作表：" & targetSheetName, vbInformation
    Else
        ' 清空现有数据（保留表头）
        wsTarget.Rows("2:" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row).ClearContents
        MsgBox "工作表「" & targetSheetName & "」已存在，将更新数据", vbExclamation
    End If
    
    ' 筛选并复制对应sha编号的数据
    lastSourceRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    nextTargetRow = 2 ' 从第2行开始粘贴（表头已占第1行）
    
    Dim i As Long
    For i = 2 To lastSourceRow
        If wsSource.Cells(i, SHA_COLUMN).Value = targetShaNumber Then
            wsSource.Rows(i).Copy Destination:=wsTarget.Rows(nextTargetRow)
            nextTargetRow = nextTargetRow + 1
        End If
    Next i
    
    ' 自动调整列宽
    wsTarget.Columns.AutoFit
    MsgBox "数据同步完成", vbInformation
End Sub

关键注意事项 #

• 必须根据实际表格修改SOURCE_SHEET_NAME（原始数据工作表名）和SHA_COLUMN（sha字段所在列）
• 需补充完整28个卫生署名称与编号的Select Case对应关系
• 若目标工作表已存在，会清空原有数据并重新写入最新筛选结果，避免数据重复
• 自动复制表头并调整列宽，优化表格可读性

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