Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Filtering reports by manager (including icons)

Status
Not open for further replies.

EliseFreedman

Programmer
Dec 6, 2002
470
GB
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?

Extract_aprnye.jpg
Code:
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
 
 https://files.engineering.com/getfile.aspx?folder=c60d6e98-6c19-4e97-8c61-778bbb48a805&file=Extract.jpg
Elsie,

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



Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein
 
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)
 
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,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein
 
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
 
Great!

Skip,
[sub]
[glasses]Just traded in my OLD subtlety...
for a NUance![tongue][/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top