Question

所以我有一个连接源，它从URL导入XML文件。 XML包含一些格式为mm / dd / yy的日期，但是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

感谢任何帮助。

修改

Error in regards to the top answer

EDIT2：我不确定它是什么，但使用.value = .value确定无效。我使用如下所示的简单代码对其进行了测试：

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不支持多线程。你可能可以通过多个Excel实例来解决这个问题，但我并不乐观。

至于加快速度。尝试添加：

Application.ScreenUpdating = False

和

Application.ScreenUpdating = True

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

修改的

IF 您希望能够在后台执行此类操作，您需要查看使用C＃或VB.NET编写Excel加载项，因为它们支持多个 - 用户执行其他操作时可以在后台运行。（如果执行得当）

Answer 3

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

例如

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

或（ UNTESTED ）

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

从评论中跟进。

道歉。我忘了提一件事。如果找不到非空单元格，则会出现错误，因此您需要使用On Error resume next

例如

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

进一步减少代码

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

无需复制/粘贴即可执行单元格值修改 - VBA

3 个答案: