如何将字体和内部颜色从一个多单元格范围复制到另一个？

Question

I have a range with several cells, and I want to copy that range's font colors and interior colors to another range of the same size. I'm using this code to test:

Sub testColorCopy()

Dim sht As Worksheet
Dim rng As Range
Dim rng2 As Range

Set sht = ThisWorkbook.Sheets("Sheet1")
sht.Range("a1").value = "abc"
sht.Range("c1").value = "def"
sht.Range("a1").Font.ColorIndex = 3
sht.Range("b1").Interior.ColorIndex = 4

Set rng = sht.Range("a1:b1")
Set rng2 = sht.Range("c1:d1")

rng2.Interior.color = rng.Interior.color
rng2.Font.color = rng.Font.color


End Sub

This doesn't copy the correct colors, though; the two destination cells end up black, suggesting that maybe the color values from the source cells were added together?

Iterating through each cell in the range works, but that solution doesn't scale well--I need something that will handle 1,000,000+ cells reasonably quickly.

EDIT: I only want to copy font color and interior color--no other formatting properties.

Answer 1

Here's a different approach to your problems using offsets. Your offset is the rowid and colid of the first cell of range to be pasted onto.

  Sub testColorCopy()

    Dim sht As Worksheet
    Dim rng As Range
    Dim rng2 As Range

    Set sht = ThisWorkbook.Sheets("Feuil1")
    sht.Range("a1").Value = "abc"
    sht.Range("b1").Value = "def"
    sht.Range("a1").Font.ColorIndex = 3
    sht.Range("b1").Interior.ColorIndex = 4

    Set rng = sht.Range("a1:b1")

    Dim rowoffset As Long: rowoffset = 0
    Dim coloffset As Long: coloffset = 2

    For Each cell In rng
    cell.Offset(rowoffset, coloffset).Interior.ColorIndex = cell.Interior.ColorIndex
    cell.Offset(rowoffset, coloffset).Font.ColorIndex = cell.Font.ColorIndex
    Next cell


End Sub

Example output:

Edit: Sorry, did not read your last sentence. Here's how it is done without iterating through the cells:

Sub testColorCopy()

Dim sht As Worksheet
Dim rng As Range
Dim rng2 As Range

Set sht = ThisWorkbook.Sheets("Feuil1")
sht.Range("a1").Value = "abc"
sht.Range("b1").Value = "def"
sht.Range("a1").Font.ColorIndex = 3
sht.Range("b1").Interior.ColorIndex = 4

Set rng = sht.Range("a1:b1")
Set rng2 = sht.Range("c1:d1")

rng.Copy
rng2.Parent.Activate
rng2.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End Sub