执行单元格值修改而不复制/粘贴 – VBA

所以我有一个连接源，从URL导入XML文件。 XML包含几个以mm / dd / yy格式化的date，但是Excel似乎不能确定它是20xx，而是要求我在每次刷新之后指定它是19xx还是20xx。数据（数据每天更新）。

所以我做了一个脚本来修复这个问题，使用复制/粘贴。 问题在于它很慢，不能在后台完成。 如果我在不同的工作表上运行脚本，它会开始快速更换工作表并冻结几秒钟。 这里是我的代码如下：

Sub test() Dim listCols As ListColumns Set listCols = Sheets("RawData").ListObjects("RawTable").ListColumns 'Sets the very last row & column to 0, to be copied later Range("XFD1048576").Value = "0" For col = 1 To listCols.Count 'Iterate through columns in table If listCols(col) = "DATECOL1" Or listCols(col) = "DATECOL2" Or listCols(col) = "DATECOL3" _ Or listCols(col) = "DATECOL4" Or listCols(col) = "DATECOL5" Or listCols(col) = "RESERVATIONEND" Then For Each cell In listCols(col).DataBodyRange.Cells If cell.Value <> "" Then 'ignore empty cells 'Copies the very last column & row With Range("XFD1048576") .Copy End With 'Pastes the '0' value from above and adds it to the original value in the cell it is pasting in With cell .PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd .NumberFormat = "mm/dd/yy" End With Application.CutCopyMode = False End If Next End If Next Range("XFD1048576").ClearContents 'Clear the '0' in there End Sub 

任何帮助表示赞赏。

编辑：

编辑2：我不知道它是什么，但使用.value = .value definitey作品。 我使用如下所示的简单代码对其进行了testing：

 Sub test3() With Range("W1:W59") .Value = .Value .NumberFormat = "mm/dd/yy" End With End Sub 

Answer 1

她是一个更有效的代码版本。 它避免了复制/粘贴操作，以及循环遍历单元格

 Sub Demo() Dim listCols As ListColumns Dim col As Long Dim cell As Range Set listCols = Sheets("RawData").ListObjects("RawTable").ListColumns FormatDates listCols("DATECOL1") FormatDates listCols("DATECOL2") FormatDates listCols("DATECOL3") FormatDates listCols("DATECOL4") FormatDates listCols("DATECOL5") FormatDates listCols("RESERVATIONEND") End Sub Private Sub FormatDates(ListCol As ListColumn) Dim rng As Range, arr As Range On Error Resume Next Set rng = ListCol.DataBodyRange.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not rng Is Nothing Then For Each arr In rng.Areas With arr .NumberFormat = "mm/dd/yy" .Value = .Value End With Next End If End Sub 

Answer 2

不幸的是，你不能运行用VBA编写的任何东西“在后台”。 VBA不支持multithreading。 尽pipe你可能可以用Excel的多个实例逃脱，但是我并不积极。

至于加速起来。 尝试添加：

 Application.ScreenUpdating = False 

和

 Application.ScreenUpdating = True 

分别到你的程序的开始和结束，看看是否帮助你。

编辑

如果你想在后台做这样的事情，你需要看看用C＃或VB.NET编写一个Excel插件，因为它们支持multithreading，并且可以在后台运行用户做别的事情。 （如果正确执行）

Answer 3

而不是循环遍历范围内的每个单元格，然后做一个pastespecial，一次性确定非空白单元格。 为此，您可以使用.SpecialCells(xlCellTypeConstants)

例如

 ws.columns(1).SpecialCells(xlCellTypeConstants).PasteSpecial _ xlPasteValues, xlPasteSpecialOperationAdd 

或（ UNTESTED ）

 listCols(col).DataBodyRange.Cells.SpecialCells(xlCellTypeConstants).PasteSpecial _ xlPasteValues, xlPasteSpecialOperationAdd 

后续从评论。

我很抱歉。 我忘了提到一件事。 如果未find非空白单元格，则会出现错误，因此您需要使用“下一个错误”继续

例如

 Dim Rng As Range '<~~ Declare this at the top 

并在循环内使用这个

 On Error Resume Next Set Rng = listCols(col).DataBodyRange.Cells.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not Rng Is Nothing Then Rng.PasteSpecial xlPasteValues, _ xlPasteSpecialOperationAdd Set Rng = Nothing End If 

您可以使用SELECT CASE进一步减less代码

 For col = 1 To listCols.Count 'Iterate through columns in table Range("XFD1048576").Copy Select Case listCols(col) Case "DATECOL1", "DATECOL2", "DATECOL3", _ "DATECOL4", "DATECOL5", "RESERVATIONEND" On Error Resume Next Set Rng = listCols(col).DataBodyRange.Cells.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not Rng Is Nothing Then Rng.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd Rng.NumberFormat = "mm/dd/yy" End If End Select Next