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.:help

[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. :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.

[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!!:clap2: