下拉列表中的 VBA 新建工作表

Question

我有一个电子表格，其中包含来自不同卫生当局的医院患者的数据。我使用 VBA，我正在尝试创建一个宏来创建一个新的电子表格，其中仅包含属于该卫生机构的人员的数据。卫生当局用数字标识：

首先，我创建了一个包含卫生当局列表的下拉框。我已经创建了一个按钮来插入我正在寻找的宏。我现在需要做的是编写 VBA 代码，创建一个仅包含从下拉列表中选择的卫生当局的工作表。

这是我想出的，但我认为整个代码都不正确。

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("Q42")) Is Nothing Then
    Select Case Range("Q42")
        Case "Insert Blank rows": Macro1
        Case "Hide All Sheets": Macro2
        Case "Convert to Date": Macro3
    End Select
End If
End Sub

新工作表的名称应为所选卫生当局的名称。 收集的数据位于与我放置按钮的位置不同的工作表中：数据在“数据”工作表上，按钮在“用户”工作表上。

非常感谢任何帮助。

Answer 1

您没有提供足够的信息来弄清楚如何为每个机构过滤患者列表。此代码只是如何在您的文件中创建工作表。

此代码基于工作表上选定的权限 ID 而不是组合或列表框。
如果需要，我还使用了一个查找表来重命名您的权限。您只需要列出需要重命名的权限。如果替换名称不在列表中，它将使用原始名称。

Option Explicit

Public Sub Test()

    'HARange are the selected cells in your Health Authority Range.
    Dim HARange As Range
    Set HARange = Selection
    
    'Create a new workbook with a single sheet.
    Dim wrkBk As Workbook
    Set wrkBk = Workbooks.Add(xlWBATWorksheet)
    
    'Look at each cell in your selection.
    Dim Itm As Range
    For Each Itm In HARange
    
        'Create a new worksheet and store its reference in the wrkSht variable.
        Dim wrkSht As Worksheet
        Set wrkSht = wrkBk.Worksheets.Add
        
        'Rename the worksheet and move it to the end.
        With wrkSht
            .Name = ReplacementName(Itm) 'Pass the cell to the ReplacementName function.
            .Move After:=wrkBk.Worksheets(wrkBk.Worksheets.Count)
        End With
    Next Itm
    
    'Providing new sheets were created in the new workbook then
    'delete the first (blank) worksheet.
    'DisplayAlerts are disabled so it quietly deletes the sheet
    'rather than warning you about it first.
    If wrkBk.Worksheets.Count > 1 Then
        Application.DisplayAlerts = False
        wrkBk.Worksheets(1).Delete
        Application.DisplayAlerts = True
    End If
    
End Sub

'Find the Authority ID in the lookup table and return the value to the right of it.
'If it's not found return the original authority name instead.
Private Function ReplacementName(AuthorityID As Range) As String

    With ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
        Dim rFound As Range
        Set rFound = .ListColumns("ID").Range.Find(What:=AuthorityID, _
                                                   After:=.ListColumns("ID").Range.Cells(1), _
                                                   LookIn:=xlValues, _
                                                   LookAt:=xlWhole, _
                                                   SearchOrder:=xlByRows, _
                                                   SearchDirection:=xlNext)
        If Not rFound Is Nothing Then
            ReplacementName = rFound.Offset(, 1)
        Else
            ReplacementName = AuthorityID.Offset(, 1)
        End If
        
    End With

End Function