如何复制工作表特定颜色的单元格并将其粘贴到其他工作簿中

Question

我对VBA非常陌生，我想知道如何只复制工作表的白细胞，并将它们粘贴到相同的位置，但是粘贴到另一本工作簿上。

具体来说，我有两个带有多个工作表的工作簿，它们是相同的，但是源工作簿有一些空白单元格，而目标工作簿中这些单元格是空的。我希望将这些值从源白细胞传输到目标白细胞。如果可能的话，我想用"0“填充空白的白格。

我找到了一些代码，可以将所有颜色的单元格复制到另一个excel工作表中，但它们不会转移到另一个工作簿和确切的位置。

Sub CopyHighlightedTransactions()

Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet

Set ATransWS = Worksheets("All Transactions")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("Highlighted Transactions")


For Each TransIDCell In TransIDField

    If TransIDCell.Interior.Color = RGB(255, 0, 0) Then
        
        TransIDCell.Resize(1, 10).Copy Destination:= _
            HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
            
    End If

Next TransIDCell

HTransWS.Columns.AutoFit

End Sub

提前谢谢你。

Answer 1

​

​

如果上面的动画是您的意思(如果我对您的理解是正确的)，那么也许您想试试下面的下面的内容：

Sub test()
Dim wbS As Worksheet: Dim wbT As Worksheet
Dim rgData As Range: Dim c As Range
Application.ScreenUpdating = False

'prepare variable for the workbook and sheet of the source and target
Set wbS = Workbooks("Source.xlsm").Sheets("Sheet1") 'change as needed
Set wbT = Workbooks("Target.xlsx").Sheets("Sheet1") 'change as needed

'the range of the data to be searched
Set rgData = wbS.Range("A1:D10") 'change as needed

'prepare the color to be searched
  With Application.FindFormat
  .Clear
  .Interior.Color = vbWhite
  End With

'start searching as c variable
Set c = rgData.Find(What:=vbNullString, SearchFormat:=True)

'loop until all cells in rgData is checked if the color is white or not
'if found white then copy the c, paste to wbT with that c address
    If Not c Is Nothing Then
        FirstAddress = c.Address
            Do
                c.Copy Destination:=wbT.Range(c.Address)
                Set c = rgData.Find(What:=vbNullString, after:=c, SearchFormat:=True)
            Loop While c.Address <> FirstAddress
    End If
    
End Sub

若要测试代码，请复制工作簿(源和目标)。复制子，粘贴到复制的工作簿上，然后运行它。必须打开这两本工作簿。如果您的数据范围很大，这将需要时间，因为代码将检查rgData中具有白色的所有单元格。

源工作簿中填充了一些白细胞

请记住，代码正在寻找填充白色的单元格。

我很好奇下面的test2子是否更快，因为没有循环。

Sub test2()
Dim rgW_orig As Range: Dim rgDest As Range
Dim rgW As Range: Dim rgX As Range
Dim rgBlank As range

Application.ScreenUpdating = False

Set rgW_orig = Sheets(1).Range("A1:D10")
Set rgDest = Workbooks("Target.xlsx").Sheets(1).Range(rgW_orig.Address)

With Application.FindFormat.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

Workbooks.Add
    Set rgW = ActiveSheet.Range(rgW_orig.Address)
    rgW_orig.Copy Destination:=rgW
        With rgW
            .Replace What:="", Replacement:=True, LookAt:=xlPart, SearchOrder _
                :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=False
            Set rgX = .SpecialCells(xlConstants, xlLogical)
        End With
    rgW.Value = "": rgX.Value = 1
    set rgBlank = rgW.SpecialCells(xlBlanks)
    rgW.Value = rgW_orig.Value
    rgBlank.ClearContents
    rgW.Copy
    rgDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Close False

End Sub

test2宏使用一个新的工作簿作为助手，并假设Source.xlsm中的数据范围(宏所在的地方)在Target.xlsx的数据范围内是相同的。

首先，它在新工作簿中为rgW_orig设置了与rgW变量相同的地址范围。然后复制rgW_orig并将其粘贴到rgW

然后在新的工作簿(助手工作簿)中：

它获得所有填充白色的单元格(用真正的布尔值替换该单元格)，将其设置为rgX变量。

接下来，它将整个范围( rgW)填充为空白，并将rgX填充为1，然后将没有值(空白)的所有单元格作为rgBlank变量。

它再次将rgW_orig复制到rgW中，然后清除rgBlank的内容。现在，在rgW中的辅助工作簿中，值的单元格仅为白色单元格，其余单元格为空白。

最后，它复制rgW，将“跳过空白”粘贴到rgDest中，然后不保存就关闭助手工作簿。

不过，还是不太确定这个test2潜艇是否比之前的潜艇快。