如何复制和粘贴值并且没有格式？

Question

我尝试了ActiveCell.PasteSpecial Paste:=xlPasteValues。

Sub CopyCoverage()

Dim x As Worksheet, y As Worksheet, LastRow

Set x = Sheets("1SalesAnalysis")
Set y = Sheets("Basics")

LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row

x.Range("A2:A" & LastRow).Copy y.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
x.Range("B2:B" & LastRow).Copy y.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
x.Range("C2:C" & LastRow).Copy y.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
x.Range("D2:D" & LastRow).Copy y.Cells(Rows.Count, "L").End(xlUp).Offset(1, 0)

x.Range("E2:E" & LastRow).Copy y.Cells(Rows.Count, "M").End(xlUp).Offset(1, 0)
x.Range("F2:F" & LastRow).Copy y.Cells(Rows.Count, "P").End(xlUp).Offset(1, 0)
x.Range("G2:G" & LastRow).Copy y.Cells(Rows.Count, "Q").End(xlUp).Offset(1, 0)
x.Range("H2:H" & LastRow).Copy y.Cells(Rows.Count, "R").End(xlUp).Offset(1, 0)

x.Range("I2:I" & LastRow).Copy y.Cells(Rows.Count, "S").End(xlUp).Offset(1, 0)
x.Range("J2:J" & LastRow).Copy y.Cells(Rows.Count, "T").End(xlUp).Offset(1, 0)
x.Range("K2:K" & LastRow).Copy y.Cells(Rows.Count, "V").End(xlUp).Offset(1, 0)
x.Range("L2:L" & LastRow).Copy y.Cells(Rows.Count, "W").End(xlUp).Offset(1, 0)

x.Range("O2:O" & LastRow).Copy y.Cells(Rows.Count, "EA").End(xlUp).Offset(1, 0)
x.Range("P2:P" & LastRow).Copy y.Cells(Rows.Count, "EI").End(xlUp).Offset(1, 0)
x.Range("Q2:Q" & LastRow).Copy y.Cells(Rows.Count, "EB").End(xlUp).Offset(1, 0)

x.Range("R2:R" & LastRow).Copy y.Cells(Rows.Count, "EJ").End(xlUp).Offset(1, 0)
x.Range("S2:S" & LastRow).Copy y.Cells(Rows.Count, "EC").End(xlUp).Offset(1, 0)
x.Range("T2:T" & LastRow).Copy y.Cells(Rows.Count, "EK").End(xlUp).Offset(1, 0)

ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

End Sub

Answer 1

将映射规则存储在一个数组中，这样您就可以对每列重用相同的代码。

Option Explicit
Sub CopyCoverage()
Dim wsX As Worksheet, wsY As Worksheet
Dim LastRowX As Long, msg As String
Dim rngX As Range, rngY As Range

Set wsX = Sheets("1SalesAnalysis")
Set wsY = Sheets("Basics")
LastRowX = wsX.Cells.SpecialCells(xlCellTypeLastCell).Row

Dim map, ar, i As Integer
map = Split("A=>E,B=>F,C=>G,D=>L,E=>M,F=>P,G=>Q,H=>R,I=>S,J=>T,K=>V,L=>W," & _
"O=>EA,P=>EI,Q=>EB,R=>EJ,S=>EC,T=>EK", ",")

Application.ScreenUpdating = False
For i = 0 To UBound(map)
ar = Split(map(i), "=>")
msg = msg & vbLf & ar(0) & " to " & ar(1)
Set rngX = wsX.Range(ar(0) & "2:" & ar(0) & LastRowX)
Set rngY = wsY.Cells(Rows.Count, ar(1)).End(xlUp).Offset(1, 0)
rngY.Resize(rngX.Rows.Count).Value2 = rngX.Value2
Next
Application.ScreenUpdating = True
MsgBox "Copied " & msg, vbInformation
End Sub

Answer 2

避免格式不被复制/粘贴的最佳方法是首先不复制/粘贴：您可以简单地执行：

Destination_Range.Value = Source_Range.Value

像这样，只有值被复制"；，但是不涉及格式化。

更多信息可以在这个关于这个主题的参考问题中找到。

Answer 3

这一行的"复制粘贴"已经完成了复制粘贴的任务，所以代码底部的ActiveCell.PasteSpecial什么都不做。

有几种方法可以做到这一点，但我会坚持你的代码模式：

Sub CopyCoverage()

Dim x           As Worksheet
Dim y           As Worksheet
Dim LastRow     As Long

Set x = ThisWorkbook.Sheets("Sheet2")
Set y = ThisWorkbook.Sheets("Ans")
LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row

Application.ScreenUpdating = False '~turn off the 'animation' to speed up a bit

'The logic will be, copy-paste, copy-paste
x.Range("A2:A" & LastRow).Copy
y.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

x.Range("B2:B" & LastRow).Copy
y.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

'and so and so forth
'Just continue with this pattern

Application.CutCopyMode = False '~end line
Application.ScreenUpdating = True '~turn on the 'animation' again

End Sub