Loop trough cell is column, and copy values to new sheet

[prasz]

Hi, i like to loop trough column d, and copy range a:e to a new sheet where d cell values are equals, with sheet name is d cell value i attached an image.
that would still be useful if the a1:e1 range (the header) is also copyed to the sheets.

 

[mumps]

Try:

Sub AddSheets()
    Application.ScreenUpdating = False
    Dim rng As Range, v As Variant, i As Long, srcWS As Worksheet
    Set srcWS = Sheets("cikk20220908")
    v = srcWS.Range("D2", srcWS.Range("D" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With srcWS
                    .Range("A1").CurrentRegion.AutoFilter 4, v(i, 1)
                    If Not Evaluate("isref('" & v(i, 1) & "'!A1)") Then
                        Sheets.Add(After:=Sheets(Sheets.Count)).Name = v(i, 1)
                        .AutoFilter.Range.Copy Range("A1")
                    End If
                End With
            End If
        Next i
    End With
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[Joe4]

There are also a few non-VBA ways to do this.

1. You could simply use "Advanced Filters", using the filter to new location option, selecting to post the results to another sheet. So you would just have a sheet for each option.

2. In 365, you can make use of the new "Filter" function. So if you set up each sheet with headers, you could then add this dynamic spill formula to it.
So, if you set up a sheet named "EGYA" with headers in row 1, you can put this formula in cell A2 and it will return all the "EGYA" data:

=FILTER(cikk20220908!A1:E7,cikk20220908!D1:D7="EGYA")

and repeat the process for the other sheets.

 

[prasz]

Try:

Sub AddSheets()
    Application.ScreenUpdating = False
    Dim rng As Range, v As Variant, i As Long, srcWS As Worksheet
    Set srcWS = Sheets("cikk20220908")
    v = srcWS.Range("D2", srcWS.Range("D" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With srcWS
                    .Range("A1").CurrentRegion.AutoFilter 4, v(i, 1)
                    If Not Evaluate("isref('" & v(i, 1) & "'!A1)") Then
                        Sheets.Add(After:=Sheets(Sheets.Count)).Name = v(i, 1)
                        .AutoFilter.Range.Copy Range("A1")
                    End If
                End With
            End If
        Next i
    End With
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Excellent, thank you very mutch

 

[mumps]

You are very welcome.