Option Explicit

Sub FilterAndCopyUniqueTerms()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim uniqueTerms As Object
    Dim term As Variant
    Dim rng As Range
    Dim cell As Range
    
    'turn off as much background processes as possible
    'turn off as much background processes as possible
    With Excel.Application
            .ScreenUpdating = False
            .Calculation = Excel.xlCalculationManual
            .EnableEvents = False
    End With
    
    
    Set wsSource = ThisWorkbook.Sheets("Cost Centers")
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
    
    Set uniqueTerms = CreateObject("Scripting.Dictionary")
    
    
    
    For Each cell In wsSource.Range("D2:D" & lastRow)
        If Not uniqueTerms.exists(cell.Value) Then
            uniqueTerms.Add cell.Value, cell.Value
        End If
    Next cell
    
    For Each term In uniqueTerms.keys
        Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsDest.Name = term
        
        wsSource.Rows(1).EntireRow.Copy Destination:=wsDest.Rows(1)
        
        For Each cell In wsSource.Range("D1:D" & lastRow)
            If cell.Value = term Then
                cell.EntireRow.Copy Destination:=wsDest.Cells(wsDest.Cells(wsDest.Rows.Count, "D").End(xlUp).Row + 1, 1)
                Columns("E:H").Select
                Selection.Clear
                Range("A1").Select
                Dim i As Integer
                Cells.EntireColumn.AutoFit
                    For i = 1 To ActiveSheet.UsedRange.Columns.Count
                        Columns(i).ColumnWidth = Columns(i).ColumnWidth
                    Next i

                wsDest.Range("A:A").EntireRow.AutoFit
            End If
        Next cell
    Next term

 '*******************************************************************
'Code from here down to next line of asterisks

    Dim UsedRange As Range
    For Each cell In wsSource.Range("B2:B" & lastRow)
       If cell.Value = "" Then
          Exit For
       Else
          Sheets(cell.Value).Select
          Sheets(cell.Value).UsedRange.Select
          
        Sheets(cell.Value).Selection.Copy Destination:=wsDest.Range("A1:A" & Rows.Count).End(xlUp).Offset(1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'wsDest.Range("A1:A" & Rows.Count).End(xlUp).Offset(1).Select
        'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        '    :=False, Transpose:=False
        
       End If
    Next 'sheet_name

'Code from here up to next line of asterisks    
 '*******************************************************************

   'End macro with ...
    With Excel.Application
            .ScreenUpdating = True
            .Calculation = Excel.xlAutomatic
            .EnableEvents = True
    End With
End Sub