“我试图使条件有效,但没有结果,必须有一种方法可以在单元格满足条件时将单元格粘贴为格式(单元格颜色为 RGB(128、128、128)),否则粘贴所有值,如下编码不起作用,我希望这次我的问题能被接受,任何帮助将不胜感激!请在 DropBox 链接 >>>“ 文件中找到我的 Excel 工作簿
Sub CopyPasteSave()
Dim wbSource As Excel.Workbook
Dim wbTarget As Excel.Workbook
Dim nm As Name
Dim ws As Worksheet
Dim CellsToCopy() As String
Dim i As Long
Dim Path As String
Dim rcell As Range
Dim lastCol As String
Dim lastRow As String
Dim cell As Range
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then
Exit Sub
End If
Set wbSource = ActiveWorkbook
Set rcell = Sheets("EPF Daily Report").Range("I5")
Path = "D:\"
'Enter cells to copy with formulas
CellsToCopy = Split(("B11,B12"), ",")
Application.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Sheet names go inside quotes, separated by commas
On Error GoTo ErrCatcher
wbSource.Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hyperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
Set wbTarget = ActiveWorkbook
For Each ws In wbTarget.Worksheets
With ws
.Cells.Select
For Each cell In Selection
If cell.Interior.Color = Excel.XlRgbColor.rgbGrey Then
.[A1].PasteSpecial Paste:=xlFormats ' paste the formulas that i want to keep
Else
.[A1].PasteSpecial Paste:=xlValue ' all other cells paste them as values
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
.Cells.Hyperlinks.Delete
Application.DisplayAlerts = False
Application.Goto .Range("A1")
Next
End With
Next ws
With wbTarget
' Remove named ranges
For Each nm In .Names
nm.Delete
Next nm
' Input box to name new file
'NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
.SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls"
.Close SaveChanges:=True
End With
Exit_Point:
Application.ScreenUpdating = False
Application.DisplayAlerts = True
Exit Sub
ErrCatcher:
MsgBox "specified sheets do not exist within this work book"
Resume Exit_Point
End Sub