Hi Guys I have this code which create unique workbooks by filtering the column 12 in one sheet.
I was wondering if there is a way to change it so it filters column 12 in all sheets and then
create a work book with all the tabs that were in the source book and save the values respectively.

'Force the explicit declaration of variables
Option Explicit
Sub CreateWorkbooks()

'===============================================================================================
'Macro to create unique workbooks
'
'
'
'================================================================================================
'

    'Declare the variables
    Dim strDestPath As String
    Dim strSaveAsFilename As String
    Dim strFileExt As String
    Dim strBadChars As String
    Dim Msg As String
    Dim wkbSource As Workbook
    Dim wksSource As Worksheet
    Dim wkbDest As Workbook
    Dim wksDest As Worksheet
    Dim wksTemp As Worksheet
    Dim rngData As Range
    Dim rngUniqueVals As Range
    Dim rngCell As Range
    Dim FileFormatNum As Long
    Dim CalcMode As Long
    Dim LastRow As Long
    Dim CellCount As Long
    Dim i As Long
    Dim bAborted As Boolean
    
    Sheets("DATA").Activate
    
    Application.ScreenUpdating = False
    
    LastRow = Sheets("DATA").Cells(Rows.Count, "A").Row

    'Check if the active sheet is a worksheet
    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "Please make sure that the worksheet containing" & vbCrLf & _
            "the data is the active sheet, and try again!", vbExclamation
        Exit Sub
    End If
    
    'Check if the worksheet contains data
    If ActiveSheet.UsedRange.Rows.Count = 1 Then
        MsgBox "No data is available.  Please try again!", vbExclamation
        Exit Sub
    End If
    
    'Specify the path to the folder in which to save the newly created files
    strDestPath = "D:\Users\qv8\Desktop\New folder"
    'strDestPath = InputBox("Enter the destination path for seperated spreadsheets", "Msg Box")
    'Make sure that the path ends in a backslash
    If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
    
    'Check if the path exists
    If Len(Dir(strDestPath, vbDirectory)) = 0 Then
        MsgBox "The path to your folder does not exist.  Please check" & vbCrLf & _
            "the path, and try again!", vbExclamation
        Exit Sub
    End If
    
    'Define the illegal characters for a filename
    strBadChars = "\/<>?[]:|*"""
    
    'Set the active workbook
    Set wkbSource = ActiveWorkbook
    
    'Set the active worksheet
    Set wksSource = ActiveSheet
    
    'Set the file extension and format
    If Val(Application.Version) < 12 Then
        strFileExt = ".xlsx"
        FileFormatNum = 51
    Else
        
            strFileExt = ".xlsx"
            FileFormatNum = 51
        
    End If
    
    'Change the settings for Calculation, EnableEvents, and ScreenUpdating
    With Application
       CalcMode = .Calculation
       .Calculation = xlCalculationManual
       .EnableEvents = False
       .ScreenUpdating = False
    End With
    
    'Turn off the AutoFilter
    wksSource.AutoFilterMode = False
    
    'Set the range for the source data
    Set rngData = wksSource.UsedRange
        
    'Create a temporary worksheet to store the unique values from Column G
    Set wksTemp = wkbSource.Worksheets.Add
    
    'Filter Column H for unique values and copy them to the temporary worksheet
    rngData.Range("A2:N" & LastRow).Columns(12).AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:="", _
        CopyToRange:=wksTemp.Range("A2"), _
        Unique:=True
        
    'Set the range for the unique values from the temporary worksheet
    With wksTemp
        Set rngUniqueVals = .Range("A3", .Cells(.Rows.Count, "A").End(xlUp))
    End With
        
    'Loop through each unique value
    For Each rngCell In rngUniqueVals
    
        'Filter for the current unique value
        'wbks.Sheets("Control").Range("A3:G3").AutoFilter Field:=7, Criteria1:=Target.Value
        'rngData.Range.AutoFilter Field:=12, Criteria1:="=" & _

        rngData.Range("A2:N" & LastRow).AutoFilter Field:=12, Criteria1:="=" & _
            Replace(Replace(Replace(rngCell.Value, "~", "~~"), "*", "~*"), _
                "?", "~?")
                
        'For versions of Excel prior to 2010, check for the SpecialCells limit
        If Val(Application.Version) < 14 Then
            CellCount = 0
            On Error Resume Next
            CellCount = rngData.Columns(1) _
                .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0
            If CellCount = 0 Then
                Msg = "The SpecialCells limit of 8,192 areas has been "
                Msg = Msg & vbNewLine
                Msg = Msg & "exceeded for the value """ & rngCell & """."
                Msg = Msg & vbNewLine & vbNewLine
                Msg = Msg & "Sort the data, and try again!"
                MsgBox Msg, vbExclamation, "SpecialCells Limitation"
                bAborted = True
                Exit For
            End If
        End If
            
        'Create a new workbook with one worksheet in which to copy the data
        Set wkbDest = Workbooks.Add(xlWBATWorksheet)
        
        'Set the destination worksheet
        Set wksDest = wkbDest.Worksheets(1)
        
        'Copy the filtered data to the destination worksheet
        rngData.SpecialCells(xlCellTypeVisible).Copy
        With wksDest.Range("A1")
            .PasteSpecial Paste:=8  'column width for Excel 2000 and later
            .PasteSpecial Paste:=xlPasteAll
            .PasteSpecial Paste:=xlPasteFormats
            .Select
            
             .Rows("1:1").RowHeight = 25
           .Rows("2:2").RowHeight = 55
           
        End With
        
              Worksheets("Sheet1").Name = "Data"

        'Define SaveAs filename for the new workbook using the current unique value
        strSaveAsFilename = rngCell.Value & strFileExt
        
        'Replace any illegal characters in the SaveAs filename with an underscore
        For i = 1 To Len(strBadChars)
            strSaveAsFilename = _
                Replace(strSaveAsFilename, Mid(strBadChars, i, 1), "_")
                strSaveAsFilename = Replace(strSaveAsFilename, "_ON BLOCK - N_ ", "")
                
        Next i
        
        'If the SaveAs filename already exists, add a date stamp to the filename
        If Len(Dir(strDestPath & strSaveAsFilename)) > 0 Then
            strSaveAsFilename = Replace(strSaveAsFilename, strFileExt, _
                " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & strFileExt)
        End If
        
        'Save the workbook
        wkbDest.SaveAs _
            Filename:=strDestPath & strSaveAsFilename, _
            FileFormat:=FileFormatNum
        
        'Close the workbook
        wkbDest.Close
        
    Next rngCell
    
    'Turn off the AutoFilter
    wksSource.AutoFilterMode = False
    
    'Delete the temporary worksheet
    Application.DisplayAlerts = False
    wksTemp.Delete
    Application.DisplayAlerts = True
    
    'Restore the settings for Calculation, EnableEvents, and ScreenUpdating
    With Application
        .Calculation = CalcMode
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    'Display a message box to alert the user of completion
    
      Application.ScreenUpdating = True
    If bAborted = False Then
        MsgBox "Individual files created for all Contract Managers", vbOKOnly, "Message!"
        
    End If
        
End Sub