vba 在excel中复制格式的快速方法

fast way to copy formatting in excel

提问by DevilWAH

I have two bits of code. First a standard copy paste from cell A to cell B

我有两段代码。首先是从单元格 A 到单元格 B 的标准复制粘贴

Sheets(sheet_).Cells(x, 1).Copy Destination:=Sheets("Output").Cells(startrow, 2)

I can do almost the same using

我可以做几乎相同的使用

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)

Now this second method is much faster, avoiding copying to clipboard and pasting again. However it does not copy across the formatting as the first method does. The Second version is almost instant to copy 500 lines, while the first method adds about 5 seconds to the time. And the final version could be upwards of 5000 cells.

现在第二种方法要快得多，避免复制到剪贴板并再次粘贴。但是，它不会像第一种方法那样跨格式复制。第二个版本复制 500 行几乎是即时的，而第一个方法增加了大约 5 秒的时间。最终版本可能会超过 5000 个单元格。

So my question can the second line be altered to included the cell formatting (mainly font colour) while still staying fast.

所以我的问题可以改变第二行以包含单元格格式（主要是字体颜色），同时仍然保持快速。

Ideally I would like to be able to copy the cell values to a array/list along with the font formatting so I can do further sorting and operations on them before I "paste" them back on to the worksheet..

理想情况下，我希望能够将单元格值与字体格式一起复制到数组/列表中，这样我就可以在将它们“粘贴”回工作表之前对它们进行进一步的排序和操作。

So my ideal solution would be some thing like

所以我理想的解决方案是这样的

for x = 0 to 5000
array(x) = Sheets(sheet_).Cells(x, 1) 'including formatting
next

for x = 0 to 5000
Sheets("Output").Cells(x, 1)
next

is it possible to use RTF strings in VBA or is that only possible in vb.net, etc.

是否可以在 VBA 中使用 RTF 字符串，或者只能在 vb.net 等中使用。

Answer*

答案*

Just to see how my origianl method and new method compar, here are the results or before and after

只是为了看看我的原始方法和新方法的比较，这里是结果或之前和之后

New code = 65msec

新代码 = 65 毫秒

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Sheets("Output").Range("B" & startrow).Font.ColorIndex = Sheets(sheet_).Range("A" & x).Font.ColorIndex 'copy font colour as well

Old code = 1296msec

旧代码 = 1296 毫秒

'Sheets("Output").Cells(startrow, 2).Value = Sheets(sheet_).Cells(x, 1)
'Sheets(sheet_).Cells(x, 1).Copy
'Sheets("Output").Cells(startrow, 2).PasteSpecial (xlPasteFormats)
'Application.CutCopyMode = False

采纳答案by Patrick Honorez

For me, you can't. But if that suits your needs, you could have speed andformatting by copying the whole range at once, instead of looping:

对我来说，你不能。但是，如果这适合您的需要，您可以通过一次复制整个范围而不是循环来提​​高速度和格式：

range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)

And, by the way, you can build a custom range string, like Range("B2:B4, B6, B11:B18")

而且，顺便说一句，您可以构建自定义范围字符串，例如 Range("B2:B4, B6, B11:B18")

---

---

edit: if your source is "sparse", can't you just format the destination at once when the copy is finished ?

编辑：如果您的源“稀疏”，您不能在复制完成后立即格式化目标吗？

回答by Durgesh

You could have simply used Range("x1").value(11)something like below:

您可以简单地使用Range("x1").value(11)以下内容：

Sheets("Output").Range("$A:$A0").value(11) =  Sheets(sheet_).Range("$A:$A0").value(11)

range has default property "Value" plus value can have 3 optional orguments 10,11,12. 11 is what you need to tansfer both value and formats. It doesn't use clipboard so it is faster.- Durgesh

范围具有默认属性“值”加上值可以有 3 个可选的 orguments 10,11,12。11 是传输值和格式所需要的。它不使用剪贴板，因此速度更快。 - Durgesh

回答by Tony Dallimore

Remember that when you write:

请记住，当你写：

MyArray = Range("A1:A5000")

you are really writing

你真的在写

MyArray = Range("A1:A5000").Value

You can also use names:

您还可以使用名称：

MyArray = Names("MyWSTable").RefersToRange.Value

But Value is not the only property of Range. I have used:

但 Value 并不是 Range 的唯一属性。我用过了：

MyArray = Range("A1:A5000").NumberFormat

I doubt

我怀疑

MyArray = Range("A1:A5000").Font

would work but I would expect

会工作，但我希望

MyArray = Range("A1:A5000").Font.Bold

to work.

上班。

I do not know what formats you want to copy so you will have to try.

我不知道您要复制什么格式，因此您必须尝试。

However, I must add that when you copy and paste a large range, it is not as much slower than doing it via an array as we all thought.

但是，我必须补充一点，当您复制和粘贴大范围时，它并不像我们所有人认为的那样通过数组进行操作慢得多。

Post Edit information

帖子编辑信息

Having posted the above I tried by own advice. My experiments with copying Font.Color and Font.Bold to an array have failed.

发布上述内容后，我根据自己的建议进行了尝试。我将 Font.Color 和 Font.Bold 复制到数组的实验失败了。

Of the following statements, the second would fail with a type mismatch:

在以下语句中，第二个语句会因类型不匹配而失败：

  ValueArray = .Range("A1:T5000").Value
  ColourArray = .Range("A1:T5000").Font.Color

ValueArray must be of type variant. I tried both variant and long for ColourArray without success.

ValueArray 必须是变体类型。我尝试了 ColourArray 的变体和 long 都没有成功。

I filled ColourArray with values and tried the following statement:

我用值填充了 ColourArray 并尝试了以下语句：

  .Range("A1:T5000").Font.Color = ColourArray

The entire range would be coloured according to the first element of ColourArray and then Excel looped consuming about 45% of the processor time until I terminated it with the Task Manager.

整个范围将根据 ColourArray 的第一个元素着色，然后 Excel 循环消耗大约 45% 的处理器时间，直到我使用任务管理器终止它。

There is a time penalty associated with switching between worksheets but recent questions about macro duration have caused everyone to review our belief that working via arrays was substantially quicker.

在工作表之间切换会造成时间损失，但最近关于宏持续时间的问题让每个人都重新审视了我们的信念，即通过数组工作要快得多。

I constructed an experiment that broadly reflects your requirement. I filled worksheet Time1 with 5000 rows of 20 cells which were selectively formatted as: bold, italic, underline, subscript, bordered, red, green, blue, brown, yellow and gray-80%.

我构建了一个可以广泛反映您的要求的实验。我用 5000 行 20 个单元格填充了工作表 Time1，这些单元格被选择性地格式化为：粗体、斜体、下划线、下标、边框、红色、绿色、蓝色、棕色、黄色和灰色 80%。

With version 1, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" using copy.

在版本 1 中，我使用 copy 将工作表“Time1”中的每 7 个单元格复制到工作表“Time2”。

With version 2, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the value and the colour via an array.

在版本 2 中，我通过通过数组复制值和颜色将工作表“Time1”中的每 7 个单元格复制到工作表“Time2”。

With version 3, I copied every 7th cells from worksheet "Time1" to worksheet "Time2" by copying the formula and the colour via an array.

在版本 3 中，我通过通过数组复制公式和颜色将工作表“Time1”中的每 7 个单元格复制到工作表“Time2”。

Version 1 took an average of 12.43 seconds, version 2 took an average of 1.47 seconds while version 3 took an average of 1.83 seconds. Version 1 copied formulae and all formatting, version 2 copied values and colour while version 3 copied formulae and colour. With versions 1 and 2 you could add bold and italic, say, and still have some time in hand. However, I am not sure it would be worth the bother given that copying 21,300 values only takes 12 seconds.

版本 1 平均耗时 12.43 秒，版本 2 平均耗时 1.47 秒，而版本 3 平均耗时 1.83 秒。版本 1 复制公式和所有格式，版本 2 复制值和颜色，而版本 3 复制公式和颜色。例如，在版本 1 和 2 中，您可以添加粗体和斜体，并且仍有一些时间。但是，鉴于复制 21,300 个值只需要 12 秒，我不确定是否值得麻烦。

** Code for Version 1**

** 版本 1 的代码**

I do not think this code includes anything that needs an explanation. Respond with a comment if I am wrong and I will fix.

我认为这段代码不包含任何需要解释的内容。如果我错了，请回复评论，我会修复。

Sub SelectionCopyAndPaste()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  Do While True
    ColSrcCrnt = (NumSelect Mod 20) + 1
    RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
    If RowSrcCrnt > 5000 Then
      Exit Do
    End If
    Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
                 Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
    If ColDestCrnt = 20 Then
      ColDestCrnt = 1
      RowDestCrnt = RowDestCrnt + 1
    Else
     ColDestCrnt = ColDestCrnt + 1
    End If
    NumSelect = NumSelect + 7
  Loop
  Debug.Print Timer - StartTime
  ' Average 12.43 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

** Code for Versions 2 and 3**

** 版本 2 和 3 的代码**

The User type definition must be placed before any subroutine in the module. The code works through the source worksheet copying values or formulae and colours to the next element of the array. Once selection has been completed, it copies the collected information to the destination worksheet. This avoids switching between worksheets more than is essential.

用户类型定义必须放在模块中的任何子程序之前。该代码通过源工作表将值或公式和颜色复制到数组的下一个元素。完成选择后，它将收集的信息复制到目标工作表。这避免了不必要的工作表之间的切换。

Type ValueDtl
  Value As String
  Colour As Long
End Type

Sub SelectionViaArray()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim InxVLCrnt As Integer
  Dim InxVLCrntMax As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single
  Dim ValueList() As ValueDtl

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  ' I have sized the array to more than I expect to require because ReDim
  ' Preserve is expensive.  However, I will resize if I fill the array.
  ' For my experiment I know exactly how many elements I need but that
  ' might not be true for you.
  ReDim ValueList(1 To 25000)

  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  InxVLCrntMax = 0      ' Last used element in ValueList.
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  With Sheets("Time1")
    Do While True
      ColSrcCrnt = (NumSelect Mod 20) + 1
      RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
      If RowSrcCrnt > 5000 Then
        Exit Do
      End If
      InxVLCrntMax = InxVLCrntMax + 1
      If InxVLCrntMax > UBound(ValueList) Then
        ' Resize array if it has been filled 
        ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
      End If
      With .Cells(RowSrcCrnt, ColSrcCrnt)
        ValueList(InxVLCrntMax).Value = .Value              ' Version 2
        ValueList(InxVLCrntMax).Value = .Formula            ' Version 3
        ValueList(InxVLCrntMax).Colour = .Font.Color
      End With
      NumSelect = NumSelect + 7
    Loop
  End With
  With Sheets("Time2")
    For InxVLCrnt = 1 To InxVLCrntMax
      With .Cells(RowDestCrnt, ColDestCrnt)
        .Value = ValueList(InxVLCrnt).Value                 ' Version 2
        .Formula = ValueList(InxVLCrnt).Value               ' Version 3
        .Font.Color = ValueList(InxVLCrnt).Colour
      End With
      If ColDestCrnt = 20 Then
        ColDestCrnt = 1
        RowDestCrnt = RowDestCrnt + 1
      Else
       ColDestCrnt = ColDestCrnt + 1
      End If
    Next
  End With
  Debug.Print Timer - StartTime
  ' Version 2 average 1.47 secs
  ' Version 3 average 1.83 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

回答by Derek Sturdy

Just use the NumberFormat property after the Value property: In this example the Ranges are defined using variables called ColLetter and SheetRow and this comes from a for-next loop using the integer i, but they might be ordinary defined ranges of course.

只需在 Value 属性之后使用 NumberFormat 属性：在本例中，范围是使用名为 ColLetter 和 SheetRow 的变量定义的，这来自使用整数 i 的 for-next 循环，但它们当然可能是普通定义的范围。

TransferSheet.Range(ColLetter & SheetRow).Value = Range(ColLetter & i).Value TransferSheet.Range(ColLetter & SheetRow).NumberFormat = Range(ColLetter & i).NumberFormat

TransferSheet.Range(ColLetter & SheetRow).Value = Range(ColLetter & i).Value TransferSheet.Range(ColLetter & SheetRow).NumberFormat = Range(ColLetter & i).NumberFormat

回答by Xophmeister

Does:

做：

Set Sheets("Output").Range("$A:$A0") =  Sheets(sheet_).Range("$A:$A0")

...work? (I don't have Excel in front of me, so can't test.)

...工作？（我面前没有 Excel，所以无法测试。）