EliseFreedman
Programmer
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?
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?
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