PDA

View Full Version : 90% there - Maybe paste as picture instead to esure cond format?



whatsapro
06-10-2016, 06:29 AM
All,

I'm 90% there with this VBA code. One really annoying piece of the puzzle I just cannot solve. Almost all the conditional formatting is copy and pasted into new sheet except for one piece just doesn't work. I'm about to give up. I don't need the new sheet to be editable, just viewable. Is it a wild idea to copy and paste as image on new sheet? Anyone know how I can give that a try?

Any ideas will be appreciated.



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim cwkb As Workbook
Set cwkb = ThisWorkbook
'Dim wkb As Workbook
Dim mySel As Range, aCell As Range
Dim folderPath As String
Dim LR As Long
folderPath = Application.ActiveWorkbook.Path

If Not Intersect(Range("O2:O400"), Target) Is Nothing Then
If WorksheetFunction.IsError(Target.Value) Then

ElseIf Target.Value <> "" Then
Dim ws As Worksheet
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets(Left(Target.Value, Len(Target.Value) - 1)).Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = Left(Target.Value, Len(Target.Value) - 1)

'Set wkb = Workbooks.Open(folderPath & "\DLA Supportability_Report 5-6-16 improved")


With cwkb.Sheets(2)
.AutoFilterMode = False
.Range("A1:Y1").AutoFilter

.Range("A1:Y1").AutoFilter Field:=1, Criteria1:=Left(Target.Value, Len(Target.Value) - 1)


End With


'~~> Change this to the relevant sheet
'Set ws = wkb.Sheets(1)
'~~> Change this to the relevant range
' Set mySel = wkb.Sheets(1).Range("I1:U1000")
For Each aCell In cwkb.Sheets(2).AutoFilter.Range.Cells
With aCell

.Interior.Color = .DisplayFormat.Interior.Color

End With
Next aCell

'
'~~> Now Do the copying
'
'~~> Once you are done, close the sorce worksheet without saving
cwkb.Sheets(2).AutoFilter.Range.Copy

cwkb.Sheets(Left(Target.Value, Len(Target.Value) - 1)).Paste
cwkb.Sheets(Left(Target.Value, Len(Target.Value) - 1)).Cells.EntireColumn.AutoFit
Application.DisplayAlerts = False
'wkb.Close SaveChanges:=False



Dim s As Worksheet
Dim c As Worksheet
Dim x As Integer
x = 0
'// store current sheet
Set c = ActiveSheet

'// Stop flickering...
Application.ScreenUpdating = False

'// Loop throught the sheets

For Each s In ThisWorkbook.Worksheets

If x = 0 Then

x = 1

Else

'// Have to activate - SplitColumn and SplitRow are properties
'// of ActiveSheet
s.Activate

With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End If
Next

'// Back to original sheet
c.Activate
Application.ScreenUpdating = True

Set s = Nothing
Set c = Nothing

End If
End If


End Sub

snb
06-10-2016, 06:49 AM
But it's lacking 100% of Code Tags.

Paul_Hossler
06-10-2016, 08:20 AM
Is it a wild idea to copy and paste as image on new sheet? Anyone know how I can give that a try?

You can try the Camera tool. Need to add it to the QAT

It takes a range and 'copies' it as a live image to another sheet so that when you update the editable data, the live image reflects the changes

Look at 'Editable' which just uses NOW(), and then 'Camera' -- hit F9 to re-calc and the formula updates but so does the Camera image