需要根据选择更加动态的宏

Question

我有这段代码，我发现自己创建了 12 次和模块，因为我有 12 所不同的大学，每所大学都有唯一的名称。

我想更动态一点，所以当我按下一个特定的文本框（我使用文本框并绑定到宏而不是按钮）时，代码会捕捉到它，就像在 Criteria 中一样，我已经厌倦了使用 Shapes.Range(Array("DS")).Select 但无法弄清楚如何将其包含在标准中。

Atm 我制作了 12 个模块，在下面的每个代码中，更改了 Criteria:= 并且每个宏都绑定到每个按钮，但我认为应该可以有一个代码，12 个框，具体取决于哪个框什么名字（我已经全部命名）代码应该进行排序和过滤。

我非常感谢你们的帮助，很抱歉在这方面如此初学者..

如果有人想知道这个工作簿的用途（我有很多模块和宏运行 ofc 用于不同的功能）是什么，导入数据，格式化，删除和清理很多东西，然后制作一个动态 table 因为源数据每天都在变化，然后根据对大学的过滤，导出为 none vba/macro 文件（我生成一个新的 sheet我想要的信息，导出，保存）然后邮寄出去，删除 sheet，清理所有内容（我的 woorkbook）。

    Sub SortExport_DS()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets.Add(After:=Sheets("PR11_P3")).Name = "R11 (P3)" & " fram t.o.m. " & Format(Now - 1, "YYYY-MM-DD")
    
    Sheets("PR11_P3").Select
    ActiveSheet.ListObjects("PR11_P3_Tabell").Range.AutoFilter Field:=5, _
        Criteria1:="S, Daniel"
    Range("PR11_P3_Tabell[#All]").Select
    Selection.Copy
    
    Sheets(Sheets.Count).Select
    Range("A1").Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
    Dim Table As ListObject
    Set Table = ActiveSheet.ListObjects.Add(xlSrcRange, _
    Range("A10").CurrentRegion, , xlYes)
        With Table
            .Name = "PR11_P3_Temp_Tabell"
        End With
    Sheets("PR11_P3").Select
    Application.CutCopyMode = False
    Range("A10").Select

End Sub

Answer 1

经过测试并适用于我：

Sub SortExportSelected()
    
    Dim txt, ws As Worksheet, wb As Workbook, rVis As Range, wsName As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wb = ActiveWorkbook 'or ThisWorkbook
    
    'get the text from the clicked-on shape
    txt = ActiveSheet.Shapes(Application.Caller).TextFrame2.TextRange.Text
    
    wsName = "R11 (P3)" & " fram t.o.m. " & Format(Now - 1, "YYYY-MM-DD")
    'if a sheet with this name already exists, delete it
    Application.DisplayAlerts = False
    On Error Resume Next 'ignore error if no matched sheet
    ThisWorkbook.Sheets(wsName).Delete
    On Error GoTo 0      'stop ignoring errors
    Application.DisplayAlerts = True
    
    Set ws = wb.Worksheets.Add(After:=Sheets("PR11_P3")) 'get reference to the added sheet
    ws.Name = wsName
    
    With wb.Worksheets("PR11_P3").ListObjects("PR11_P3_Tabell")
         .Range.AutoFilter Field:=5, Criteria1:=txt   'use `txt` for filtering
         .Range.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
    End With
    
    With ws.ListObjects.Add(xlSrcRange, ws.Range("A1").CurrentRegion, , xlYes)
            .Range.EntireColumn.AutoFit
            .Name = "PR11_P3_Temp_Tabell"
    End With

    With wb.Worksheets("PR11_P3")
        .Select
        .Range("A10").Select
    End With
    Application.CutCopyMode = False
    
End Sub

需要根据选择更加动态的宏

Macro that needs to be more dynamic based on selection

excel

vba