复制和其他工作簿粘贴
问题描述:
我试着去复制所有包含蓝色字体和在同一范围内源的另一个工作簿复制,但是我失去了在这一点上的细胞。每次我尝试运行此代码时,都会收到运行时错误。复制和其他工作簿粘贴
Sub test2()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim FonteA As Workbook, FonteB As Workbook
Dim ws As Worksheet
Dim vFile As Variant
Dim rCell As Range
Dim lColor As Long
Dim rColored As Range
'Set source workbook
Set FonteB = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set FonteA = ActiveWorkbook
FonteB.Worksheets("USD - SCHEDULE A").Activate
lColor = RGB(0, 0, 255)
Cells.CurrentRegion.Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Font.Color = lColor Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
If rColored Is Nothing Then
MsgBox "No cells match the color"
Else
rColored.Select
rColored.Copy
End If
Set rCell = Nothing
Set rColored = Nothing
FonteA.Worksheets("Matriz_Produto").PasteSpecial Paste:=xlPasteFormats
FonteA.Worksheets("Matriz_Produto").PasteSpecial Paste:=xlPasteValues
Application.Calculation = xlAutomatic
End Sub
答
不知道在哪里的特定错误是来自(它看起来像它实际上应该是一个错误1004),但我猜使用激活并选择将解决它只是切换。请尝试以下操作:
'Set source workbook
Set FonteB = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
'Set targetworkbook
Set FonteA = Workbooks.Open(vFile)
Dim ws As Worksheet
Set ws = FonteB.Worksheets("USD - SCHEDULE A")
lColor = RGB(0, 0, 255)
For Each rCell In ws.Cells.CurrentRegion
If rCell.Font.Color = lColor Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
什么是运行时错误? – Comintern
自动化错误-2147221080(800401a8) – Ygor
哪条线抛出呢? – Comintern