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