VBA Filter Names from List One by One and then Copy filtered data v2

[Sufiyan97]

I am using below code by @Anthony47, which is working fine, now I just want to modify code and instead of copying data in to clipboard I want to save each filtered name as separate image in a folder for that it should ask for destination folder and want to name each image same as the name filtered

and I don't want a separate message after each filtered data is saved, I just want final message when all the names from column J filtered and saved.

Sub SeqToClip_Pict()
Dim fRange As Range, fRC As Long
Dim I As Long, cFilt
'
Set fRange = Range(Range("E1"), Range("E1").End(xlDown).Offset(1, 0))   'Assuming the table starts in E1
fRC = fRange.Rows.Count
'
For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fRange.AutoFilter Field:=1, Criteria1:="*" & cFilt & "*"
    If fRange.SpecialCells(xlCellTypeVisible).Count > 2 Then             'See message 1
        Range(fRange.Cells(1, -1), fRange.Cells(fRC + 3, fRange.Columns.Count)).Copy     'See message 2
        Beep
        MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
    End If
Next I
fRange.AutoFilter Field:=1
Application.CutCopyMode = False
MsgBox ("Completed")
End Sub

My Data looks like this

Book1
	C	D	E	F	G	H	I	J	K
1	Date	Amount	Name
2	9/28/2022	5	A
3	9/28/2022	5	A
4	1	10	B
5	9/29/2022	10	B
6	9/30/2022	15	C
7	9/30/2022	15	C
8	10-01-2022	20	D
9	10-01-2022	20	D
10	1	25	E
11	10-02-2022	25	E
12
13		150	Total Quantity
14		4500	Total Amount
15
16								A
17								B
18
19
20
21
Sheet1

Cell Formulas
Range	Formula
C4,C10	C4	=B3+1
D13	D13	=SUBTOTAL(9,D2:D11)
D14	D14	=D13*30

Reference

VBA Filter Names from List One by One and then Copy filtered data

I have a data like below I a VBA to Filter Names from List (J16:J20) One by One and then Copy the filtered data: CDEFGHIJKL1NameAmount2A53A54B105B106C157C158D209D2010E2511E251213Total Quantity15014Total Amount45001516A17B18C19D20E2122232425E13E13=SUBTOTAL(9,E2:E11)E14E14=E13*30

www.mrexcel.com

 

[Sufiyan97]

Cross posted at

VBA Filter Names from List One by One and then saved filtered data

I am using below code, which is working fine, now I just want to modify code and instead of copying data in to clipboard I want to save each filtered name as separate image in a folder for that it should ask for destination folder and want to name each image same as the name filtered and I...

www.excelforum.com

 

[Kaper]

The solution has been also published on excelforum.

My proposition (both worksheets in the same workbook, and pictures in the same folder where the workbook is stored. If you do not need worksheets for reference delete 3 lines as noted in code and substitute new name assignment with sheet deleting:
PS. In naming a picture with the content, I added time and date

.Export Filename:=ThisWorkbook.Path & "\" & cFilt & Format(Now, "_yymmdd_hhmmss") & ".png", Filtername:="png"

One can save just under stright name, but then preexisting file with such name shall be deleted from the folder before

.Export Filename:=ThisWorkbook.Path & "\" & cFilt & ".png", Filtername:="png"

Final comment - note that in your file some dates are real Excel dates, some are just texts, which look like a date. Try changing all dates format to some other like dd mmmm yyyy and see that only excel dates wil follow that change, while texy s will remain unchanged

And the whole code:

Sub SeqToPNGPictures()
Dim fRange As Range, fRC As Long
Dim I As Long, cFilt As String, wks As Worksheet, table As Range
Dim pic As Picture, cht As ChartObject, lWidth As Long, lHeight As Long

Set wks = Sheets("Sheet1")
wks.Activate: wks.AutoFilterMode = False
Set fRange = Range(Range("E1"), Range("C1").End(xlDown).Offset(0, 2))   'Assuming the table starts in E1
fRC = fRange.Rows.Count

For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fRange.AutoFilter Field:=1, Criteria1:="*" & cFilt & "*"
    If fRange.SpecialCells(xlCellTypeVisible).Count > 2 Then
      On Error Resume Next 'these 3 lines down to on error got can be deleted if no sheet saving is planned
        Application.DisplayAlerts = False: Sheets(cFilt).Delete: Application.DisplayAlerts = True
      On Error GoTo 0
      Range(fRange.Cells(1, -1), fRange.Cells(fRC + 3, fRange.Columns.Count)).Copy
      With ActiveWorkbook.Sheets.Add
        .Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        .Columns("C:E").AutoFit
        Set table = .Range(.Cells(1, "C"), .Cells(.Rows.Count, "E").End(xlUp))
        table.CopyPicture xlScreen, xlPicture
        lWidth = table.Width
        lHeight = table.Height
        Set cht = .ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
        cht.Activate
        With cht.Chart
          .Paste
          .Export Filename:=ThisWorkbook.Path & "\" & cFilt & Format(Now, "_yymmdd_hhmmss") & ".png", Filtername:="png"
        End With
        cht.Delete
        .Name = cFilt
        'or if you dont need sheets, instead of .Name = cFilt  just:
        'Application.DisplayAlerts = False : .Delete : Application.DisplayAlerts = True
      End With
      wks.Activate
    End If
Next I
fRange.AutoFilter Field:=1
Application.CutCopyMode = False
MsgBox ("Completed")
End Sub

 

[Sufiyan97]

Thank you very much Kaper, working perfect!
spent around 3-4 hours on ChatGPT to get this done, but no got it working!
Thank you again for your time to write this amazing code!

 

[Sufiyan97]

Hi Kaper,

Sorry but when I tried above code in a new module in a new worksheet, it is not working,

I am getting below error

in this line

table.CopyPicture xlScreen, xlPicture

but when I use the spreadsheet which you shared in ExcelForum it is working perfect!

 

[Kaper]

probably there are some differences in formatting or something like that. Make sure your data posted with xl2bb is really representative.

 

[Sufiyan97]

I just copied the same spreadsheet which you shared and now it's working.