PDA

View Full Version : Conditional Formatting not pasting correctly with macro



whatsapro
06-06-2016, 07:50 AM
Hello Community! I have a slight issue with a macro. The conditional formatting on an external file does not paste into my new workbook correctly. The only color that shows up on the new sheets is RED for some reason. Basically, when I double click a cell in the main workbook, it should extract filtered data from an external workbook and paste that data into a new sheet on the main workbook. All works except for the color coding. The colors on the external workbook are generated using cond formatting rules. Any idea what I can do to make the formats match?


Sub AddSheets()
Dim cll As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook

For Each cll In wsWithSheetNames.Range("Q3:Q38")
If Not (Application.IsNA(cll) Or Len(cll.Text) = 0) Then
With wbToAddSheetsTo
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cll.Value
If Err.Number = 1004 Then
Debug.Print cll.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
End If
Next cll
End Sub


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

If Not Intersect(Range("O2:O1000"), 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 wkb.Sheets(1)
.AutoFilterMode = False
.Range("A1:Y1").AutoFilter

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

wkb.Sheets(1).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
End If

End If


End Sub


Private Sub filter()
With ActiveSheet
.AutoFilterMode = False
.Range("A1:Y1").AutoFilter

.Range("A1:Y1").AutoFilter Field:=24, Criteria1:=104
End With

End Sub

whatsapro
06-07-2016, 06:30 AM
Found a solution but it is SLOOOOOOOW! I'm talking like 10 minutes per double click action.

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:O20"), 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 wkb.Sheets(1)

.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 wkb.Sheets(1).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
wkb.Sheets(1).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

End If

End If


End Sub