Thread: unique values (range) to create new sheets

Frank,

Assuming that cell H4 of sheet 'ABC' is a header for data in H5:H1000, you should be able to use the following:

Sub tgr()
    
    Dim rngDest As Range
    Dim arrUnq As Variant
    Dim arrIndex As Long
    Dim xlCalc As Integer
    
    Set rngDest = Cells(1, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count + 1)
    
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    With Range("H4:H1000")
        .AutoFilter 1, "<>"
        .Copy rngDest
        .AutoFilter
    End With
    
    With Range(rngDest, rngDest.End(xlDown))
        .AdvancedFilter xlFilterCopy, , .Offset(, 1), True
        arrUnq = Application.Transpose(Range(rngDest.Offset(1, 1), rngDest.Offset(, 1).End(xlDown)).Value)
        .Resize(, 2).EntireColumn.Delete
    End With
    
    For arrIndex = 1 To UBound(arrUnq)
        Sheets("ABC").Copy After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = arrUnq(arrIndex)
            .UsedRange.AutoFilter 8, arrUnq(arrIndex)
        End With
    Next arrIndex
    
    With Application
        .Calculation = xlCalc
        .ScreenUpdating = True
    End With
    
End Sub