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
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