复制和其他工作簿粘贴

Question

我试着去复制所有包含蓝色字体和在同一范围内源的另一个工作簿复制，但是我失去了在这一点上的细胞。每次我尝试运行此代码时，都会收到运行时错误。

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 

Answer 1

不知道在哪里的特定错误是来自（它看起来像它实际上应该是一个错误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