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

[JOEYSCLEE]

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.

[mana]

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

[JOEYSCLEE]

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

Nevertheless, 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.

[mana]

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

[JOEYSCLEE]

Thanks Mana!!! It works perfectly!!