我尝试从工作表wsHR中的列复制值和条件格式，然后将其粘贴到wsHH。但是，下面的代码不会将格式复制到第二个工作表。所有值都正常粘贴，但格式不是。我已将格式添加到wsHR中并且没有条件限制，并且可以正常复制。是否有特定的方法来确保粘贴条件格式？
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的值都被粘贴 - 条件格式设置基于重复项。
答案 0 :(得分：1)
找到解决方法来获取格式。以前，您无法通过VBA中的条件格式访问内部颜色，而无需执行大量额外工作（see here）。但是，我发现自Excel 2010起，它已更改（see here）。由于我使用的是Excel 2013，因此无论格式如何（see here），我都可以使用.DisplayFormat查找内部颜色。
使用这个，我改变了：
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的结果来确定是否应该格式化第二个工作表的单元格。
答案 1 :(得分：0)
我写了一些更完整和可自定义/参数化的复制子，以相当有效的方式完成了这项任务。因此，可以决定是否复制以下内容：
XlPasteType和XlPasteSpecialOperation参数的常规粘贴操作
例如以下呼叫：
EventsDisable
PasteWithDisplayFormat Range("B40"), Range("A1:Z30")
EventsEnable
在OP示例中，应该是这样的：
With wsHH
PasteWithDisplayFormat .Range("A" & y), wsHR.Range("A" & i)
'...
End With
代替：
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'...
End With
（请随时在此处为其他人增强/扩展）
'including conditional formatting as fixed styles (DisplayFormat)
'based on Range.PasteSpecial
Public Sub PasteWithDisplayFormat( _
dst As Range, _
Optional src As Range, _
Optional pasteSpecialBefore As Boolean = True, _
Optional paste As XlPasteType = xlPasteValuesAndNumberFormats, _
Optional Operation As XlPasteSpecialOperation = xlNone, _
Optional SkipBlanks As Boolean = False, _
Optional Transpose As Boolean = False, _
Optional Borders As Boolean = True, _
Optional Font As Boolean = True, _
Optional InteriorColor As Boolean = True, _
Optional WrapText As Boolean = True, _
Optional HorizontalAlignment As Boolean = True, _
Optional VerticalAlignment As Boolean = True _
)
If src Is Nothing Then Set src = Selection
If pasteSpecialBefore Then dst.PasteSpecial paste:=paste, Operation:=Operation, SkipBlanks:=False, Transpose:=False
Dim x As Integer: For x = 1 To src.Rows.Count
For y = 1 To src.Columns.Count
Dim sf As DisplayFormat: Set sf = src.Cells(x, y).DisplayFormat 'source cells DisplayFormat
With dst.Cells(x, y)
If Borders Then CopyBorders .Borders, sf.Borders
If Font Then
.Font.ColorIndex = sf.Font.ColorIndex
.Font.Color = sf.Font.Color
.Font.Background = sf.Font.Background
.Font.FontStyle = sf.Font.FontStyle '=> bold + italic
'.Font.Bold = sf.Font.Bold
'.Font.Italic = sf.Font.Italic
.Font.Size = sf.Font.Size
.Font.Name = sf.Font.Name
End If
If InteriorColor Then .Interior.Color = sf.Interior.Color
If WrapText Then .WrapText = sf.WrapText
If HorizontalAlignment Then .HorizontalAlignment = sf.HorizontalAlignment
If VerticalAlignment Then .VerticalAlignment = sf.VerticalAlignment
End With
Next y
Next x
End Sub
Sub CopyBorders(dst As Borders, src As Borders)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
Dim bi As Integer: For bi = 1 To src.Count 'border index
CopyBorder dst(bi), src(bi)
Next bi
End Sub
Sub CopyBorder(dst As Border, src As Border)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
End Sub
'used with EventsEnable()
Sub EventsDisable()
With Application: .EnableEvents = False: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
End Sub
'used with EventsDisable()
Sub EventsEnable()
With Application: .EnableEvents = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
End Sub
这是一个示例，基于复制到临时单词文件并粘贴，但是（至少在更复杂的表上）导致某些 OLE嵌入式对象的粘贴 >不再在excel中真正可用，但可以满足其他用途：
使用xlPasteAllMergingConditionalFormats作为XlPasteType似乎会产生与上述 temp MS Word doc 方法相同的结果