Create a new sheet / workbook for all Unique values (Including Pictures / Images)

Hi, there
Would you please help to write VBA for copying all rows (Including Pictures / Images) with the same value in the column F (The Header - Vdr) of the range to a new workbooks. Hope that the macro can do for every unique value in this column. Also, hope that the sheet & file can be named after the Unique value. As a result, there will be 5 worksheets and/or workbooks with the name (AMG,LT,MY,RWT & XH)

If possible, kindly use shapes.addpicture method for those pictures/images. Enclosed the attachment for your reviewing.:help

Code:

---

Option Explicit


Sub test()
    Dim a, e
    Dim ws As Worksheet
     
    a = Array("AMG", "LT", "MY", "RWT", "XH")
    Set ws = ActiveSheet
   
    Application.ScreenUpdating = False
   
    For Each e In a
        ws.Copy
        With ActiveSheet
            .Name = e
            With .Cells(1).CurrentRegion
                .AutoFilter
                .AutoFilter 6, "<>" & e
                Application.DisplayAlerts = False
                .Offset(1).Delete
                Application.DisplayAlerts = True
                .AutoFilter
            End With
            Application.Goto .Cells(1)
        End With
    Next
   
End Sub

---

Thanks Mana for the quick response .... Above code works good. :clap:

:helpNevertheless, would you please help again? As the value of the column F (the Header - Vdr) is not same in each file. So, could you please help to modify it (instead of state the name in the VBA code every time)? Meanwhile, kindly help to improve the code for populating the filename as the vdr name as worksheet name.

Code:

---

Option Explicit


Sub test2()
    Dim dic As Object
    Dim ws As Worksheet
    Dim i As Long, Vdr As String
   
    Set dic = CreateObject("scripting.dictionary")
     
    Set ws = ActiveSheet
   
    Application.ScreenUpdating = False
   
    With ws.Cells(1).CurrentRegion
        For i = 2 To .Rows.Count
            Vdr = .Cells(i, 6).Value
            If Not dic.exists(Vdr) Then
                dic(Vdr) = True
                ws.Copy
                With ActiveSheet
                    .Name = Vdr
                    With .Cells(1).CurrentRegion
                        .AutoFilter
                        .AutoFilter 6, "<>" & Vdr
                        Application.DisplayAlerts = False
                        .Offset(1).Delete
                        Application.DisplayAlerts = True
                        .AutoFilter
                    End With
                    Application.Goto .Cells(1)
                    Application.DisplayAlerts = False
                    .Parent.SaveAs ws.Parent.Path & "\" & Vdr & ".xlsx"
                    Application.DisplayAlerts = True
                    .Parent.Close
                End With
            End If
        Next
    End With
   
End Sub

---

Thanks Mana!!! It works perfectly!!:clap2: