Question

我有两位代码。首先是从细胞A到细胞B的标准复制糊剂

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

我可以使用

做几乎一样的事

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

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

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

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

所以我理想的解决方案就是

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

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

的应答 的 *

只是看看我的origianl方法和新方法如何比较，这里是结果或之前和之后

新代码= 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

旧代码= 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

Answer 1

你可以简单地使用Range("x1").value(11) 如下所示：

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

范围具有默认属性“值”加上值可以有3个可选的参数10,11,12。 11是你需要同时改变价值和格式。它不使用剪贴板，所以它更快.- Durgesh

Answer 2

对我来说，你做不到。但如果这符合您的需求，您可以通过立即复制整个范围来进行速度和格式化，而不是循环：

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

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

编辑：如果您的来源是“稀疏的”，那么您是否只能在复制完成后立即格式化目标？

Answer 3

请记住，当你写：

MyArray = Range("A1:A5000")

你真的在写

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

您还可以使用名称：

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

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

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

我怀疑

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

可行，但我希望

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

工作。

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

但是，我必须补充一点，当你复制并粘贴一个大范围时，它并没有像我们所想的那样通过数组进行复制。

发布修改信息

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

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

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

ValueArray必须是变体类型。我为ColourArray尝试了两种变体而且没有成功。

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

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

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

工作表之间切换会产生时间损失，但最近关于宏观持续时间的问题已经让每个人都回顾了我们的信念，即通过数组工作的速度要快得多。

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

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

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

对于版本3，我通过工作表“Time1”将每个第7个单元格复制到工作表“Time2”，方法是通过数组复制公式和颜色。

版本1平均为12.43秒，版本2平均为1.47秒，而版本3平均为1.83秒。版本1复制公式和所有格式，版本2复制值和颜色，而版本3复制公式和颜色。对于版本1和版本2，您可以添加粗体和斜体，比如说，还有一些时间。但是，我不确定这是值得的，因为复制21,300个值只需要12秒。

**版本1的代码**

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

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

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

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

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

Answer 4

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

TransferSheet.Range（ColLetter＆amp; SheetRow）.Value = Range（ColLetter＆amp; i）.Value TransferSheet.Range（ColLetter＆amp; SheetRow）.NumberFormat = Range（ColLetter＆amp; i）.NumberFormat

Answer 5

的作用：

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

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

快速复制excel中的格式

5 个答案: