VBA：.Paste特殊不粘贴条件格式

问题描述：

我试图从表wsHR中的列中复制值和条件格式并将它们粘贴到wsHH中。但是，下面的代码不会将格式复制到第二个工作表。所有的值都会正常粘贴，但格式不正确。我在wsHR中添加了非条件格式，并且可以正常复制。有没有确保条件格式粘贴的具体方法？VBA：.Paste特殊不粘贴条件格式

Private Sub CommandButton1_Click() 


'Set variables 
Dim LastRow As Long 
Dim wsHR As Worksheet 
Dim wsHH As Worksheet 
Dim y As Integer 

'Set row value 
y = 4 

'Set heavy chain raw data worksheet 
Set wsHR = ThisWorkbook.Worksheets(4) 
'Set heavy chain hits worksheet 
Set wsHH = ThisWorkbook.Worksheets(6) 

'Optimizes Speed 
Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 

'Finds last row 
With wsHR 
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

'Iterates through rows in column A, and copies the row into proper sheet depending on "X" in PBS/KREBS 
For i = 4 To LastRow 
    'Checks for "X" in PBS 
    If VarType(wsHR.Range("AD" & i)) = 8 Then 
     If wsHR.Range("AD" & i).Value = "X" Or wsHR.Range("AE" & i).Value = "X" Then 
      With wsHH 
       wsHR.Range("A" & i).Copy 
       .Range("A" & y).PasteSpecial Paste:=xlPasteFormats 
       .Range("A" & y).PasteSpecial Paste:=xlPasteValues 
       'Range before PBS/KREBS 
       .Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value 
       'Adds space to keep formulas for PBS/KREBS 
       'Range after PBS/KREBS 
       .Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value 
      End With 
      y = y + 1 
     End If 
    End If 
Next i 

'Message Box when tasks are completed 
MsgBox "Complete" 

'Reset Macro Optimization Settings 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 


End Sub

我不能在第二片材，wsHH使用相同的条件格式编排规则，因为不是所有的值从wsHR在被粘贴 - 条件格式是基于重复。

所以你想在wsHH基于wsHR条件条件格式？ – OldUgly

@OldUgly我最初试图从条件格式化的单元格中复制格式，而没有意识到条件格式化的信息是单独存储的。经过大量的研究后，我找到了我在下面给出的答案。 – MTJ

很高兴你找到了一种方法去那里。 – OldUgly

答

找到解决方法来获取格式。以前，您无法通过VBA中的条件格式访问内部颜色，而无需执行大量额外工作（see here）。不过，我发现自Excel 2010起，此更改（see here）。由于我使用的是Excel 2013，因此无论格式如何，我都可以使用.DisplayFormat查找内部颜色（see here）。

利用这一点，我改变了：

With wsHH 
    wsHR.Range("A" & i).Copy 
    .Range("A" & y).PasteSpecial Paste:=xlPasteFormats 
    .Range("A" & y).PasteSpecial Paste:=xlPasteValues 
    'Range before PBS/KREBS 
    .Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value 
    'Adds space to keep formulas for PBS/KREBS 
    'Range after PBS/KREBS 
    .Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value 
End With

这样：

With wsHH 
    'Range before PBS/KREBS 
    .Range("A" & y & ":AC" & y).Value = wsHR.Range("A" & i & ":AC" & i).Value 
    'Adds space to keep formulas for PBS/KREBS 
    'Applying background CF color to new sheet 
    If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then 
    .Range("A" & y).Interior.ColorIndex = 3 
    End If 
    'Range after PBS/KREBS 
    .Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value 
End With

我不再复制和粘贴值。相反，我使用.Value来设置这些值，就像我曾经用于该行中的其他单元一样，然后使用If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then的结果来确定是否应格式化第二个工作表的单元格。

VBA：.Paste特殊不粘贴条件格式

相关推荐