Filtering reports by manager (including icons)

[EliseFreedman]

Hi There

I am trying to develop a report whereby I filter a master report by manager and send the filtered report to each manager with their data.

This worked fine until this morning when i added a traffic light system with pictures for the red, amber and green status.

Now when I run the reports, the images in the RQG status column don't copy over onto the new report. Not sure what to change to get the images into the filtered report?

Option Explicit

Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long, y As Long, ct As Long, uCol As Long

On Error GoTo ErrHandler

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Your main worksheet
Set ws = ActiveWorkbook.Sheets("Insp - Employee Non Compliance")

'Column J
uCol = 14

ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
        unique(ct) = ActiveSheet.Cells(x, uCol).Text
        ct = ct + 1
    End If
Next x

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1

    If unique(x) <> "" Then
        'add workbook
        Set wb(x) = Workbooks.Add

        'copy header row
        ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

        'loop to find matching items in ws and copy over
        For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
            If ws.Cells(y, uCol) = unique(x) Then

                'copy full formula over
                ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)

                 End If
        Next y

        'autofit
        wb(x).Sheets(1).Columns.AutoFit

        'save when done
        wb(x).SaveAs "H:\Reports\" & unique(x) & " " & Format(Now(), "mm-dd-yy")
        'wb(x).Close SaveChanges:=True

    Else
        'once reaching blank parts of the array, quit loop
        Exit For
    End If

Next x

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[SkipVought]

Elsie,

Can you explain how your traffic light system works? Is it a Conditional Format?



Skip,

_{Just traded in my OLD subtlety...
for a NUance!}
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein

 

[EliseFreedman]

Hi Skip

I am using conditional formatting in a hidden cell and then a linked picture in another column linked to cell with the conditional formatting (which contains a vlookup)

 

[SkipVought]

Is the linked pic getting copied in such a way that the link file can be referenced in you target workbooks? Maybe you need to have the actual pic and not just a link. Can't actually determine without your workbook.

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein

 

[EliseFreedman]

I got it figured out.

Went back to basics and set the status column to webdings font, in each cell I set the symbol to a black circle then used conditional formatting to change the colour of the circle. Much easier and worked like a dream

 

[SkipVought]

Great!

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein