Macro that needs to be more dynamic based on selection-CodePudding

I have this code and i find myself creating 12 times and modules since I have 12 different colleges, each with a unique names.

I would like to make a bit more dynamic, so when I press a specific textbox (I use textbox's and bind to macros instead of buttons) the code captures that and as in Criteria, have tired to use Shapes.Range(Array("DS")).Select but cant figure out how to include that within the Criterial.

Atm I have made 12 modules and within each below code, changed Criteria:= and each macro is bound to each button, but I think it should be possible to have one code, 12 boxes and depending on which box with what name (I have named them all) the code should do the sorting and the filtering.

I do appreciate your guys help and sorry for being so beginner at this..

If anyone wonders what this workbook dose (I have a lot of modules and macros running ofc for different functions) is, importing data, format it, deleting and cleaning a lot of stuff, then making a dynamic table since the source data can vary for day to day, and then based on filtering on colleges, export as a none vba/macro file (I generate a new sheet with the info I want, export that, save that) then mail it out, delete the sheet, clean everything (my 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

CodePudding user response：

Something like this:

Sub SortExportSelected()
    Dim txt, ws as worksheet, wb As Workbook 
    

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'get the text from the clicked-on shape
    txt = ActiveSheet.Shapes(Application.Caller).TextFrame2.TextRange.Text
    Set wb = ActiveWorkbook
    Set ws = wb.workSheets.Add(After:=Sheets("PR11_P3")) 'get reference to the added sheet
    ws.Name = "R11 (P3)" & " fram t.o.m. " & Format(Now - 1, "YYYY-MM-DD")
    
    With wb.WorkSheets("PR11_P3").ListObjects("PR11_P3_Tabell")
         .Range.AutoFilter Field:=5, Criteria1:=txt   'use `txt` for filtering
         .Range.Copy  ws.Range("A1")
    End With 
    
    ws.Range("A1").CurrentRegion.EntireColumn.Autofit 
    
    'A10 or A1 ?
    With ws.ListObjects.Add(xlSrcRange, ws.Range("A10").CurrentRegion, , xlYes)
            .Name = "PR11_P3_Temp_Tabell"
    End With

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

CodePudding user response：

Edited little more, thanks to @Tim Williams


Option Explicit
Sub SortCopy()
    Dim txt, wst As Worksheet, wb As Workbook
    

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    txt = ActiveSheet.Shapes(Application.Caller).TextFrame2.TextRange.Text
    Set wb = ActiveWorkbook
    Set wst = wb.Worksheets.Add(After:=Sheets("PR11_P3"))

    wst.Name = "R11 (P3)" & " fram t.o.m. " & Format(Now - 1, "YYYY-MM-DD")
    
    
    With wb.Worksheets("PR11_P3").ListObjects("PR11_P3_Tabell")
         .Range.AutoFilter Field:=5, Criteria1:=txt
         .Range.Copy wst.Range("A1")
    End With
    
    wst.Range("A1").CurrentRegion.EntireColumn.AutoFit
    
    With wst.ListObjects.Add(xlSrcRange, wst.Range("A1").CurrentRegion, , xlYes)
            .Name = "PR11_P3_Temp_Tabell"
    End With
    
    
    With wb.Worksheets("PR11_P3")
        .Select
        .Range("A10").Select
    End With
    Application.CutCopyMode = False
    
End Sub