Snasui Excel Forum

Code: Select all

Sub Calculate()
    Dim r As Range, d As Object, s As Worksheet
    Set d = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    'For Each s In Worksheets
   '     If s.Name <> Sheets(1).Name Then
    '        s.Delete
   '     End If
   ' Next s
    With Sheets(1)
        For Each r In .Range("i2", .Range("i" & .Rows.Count).End(xlUp))
        If Not d.Exists(r.Value) Then
                d.Add r.Value, r.Value
                Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
                s.Name = r.Value
                s.Range("AA1").Value = "PayorCod"
                s.Range("AA2").Value = r.Value
                .UsedRange.AdvancedFilter xlFilterCopy, _
                    s.Range("AA1:AA2"), s.Range("a1")
                s.Range("AA1:AA2").Clear
            End If
        Next r
    End With
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
End Sub

Code: Select all

Private Sub CommandButton1_Click()
    Dim r As Range, d As Object, s As Worksheet
    Dim a As String, b As Variant
    
    a = "11C1318A001,11C1118A001,11C1418A001,11C1218A001,11C1018A001,11C0918A001" _
        & ",11Y9164A000,1205794001H,11C0218A000,11C1905A000"
    b = VBA.Split(a, ",")
    Set d = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    For Each s In Worksheets
        If s.Index > 2 Then
            s.Delete
        End If
    Next s
    With Sheets(1)
        For Each r In .Range("i2", .Range("i" & .Rows.Count).End(xlUp))
            If Not d.Exists(r.Value) And InStr(a, r.Value) = 0 Then
                d.Add r.Value, r.Value
                Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
                s.Name = r.Value
                s.Range("AA1").Value = "PayorCode"
                s.Range("AA2").Value = r.Value
                .UsedRange.AdvancedFilter xlFilterCopy, _
                    s.Range("AA1:AA2"), s.Range("a1")
                s.Range("AA1:AA2").Clear
            End If
        Next r
        Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
        s.Name = "xyz"
        s.Range("AA1").Value = "PayorCode"
        s.Range("AA2").Resize(UBound(b) + 1).Value = Application.Transpose(b)
        .UsedRange.AdvancedFilter xlFilterCopy, _
            s.Range("AA1").Resize(UBound(b) + 1), s.Range("a1")
        s.Range("AA1").EntireColumn.Clear
    End With
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
End Sub