複製和其他工作簿粘貼

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