时间戳

首页 > 解决方案 > 抑制“X”下的值并复制到新工作表

excel - 抑制“X”下的值并复制到新工作表

问题描述

我正在尝试创建一个 VBA 模板，该模板可用于抑制一定数量以下的所有数据值。我已经找到/更新了一些我在网上找到的代码，它确实成功地创建了一个新工作表，传输所选数据，并根据需要将所有 30 及以下的数值替换为“< 30”。但是，它也会更新原始数据源，替换选定的数据，而不是仅更新新工作表上的数据。如何防止它修改原始数据而只修改复制到新工作表的数据？

我在这里尝试过这段代码，但没有得到想要的结果，也无法弄清楚如何修改它来实现它们：

Sub SuppressLessThan()

Dim Rng As Range
Dim WorkRng As Range
Dim ws As Worksheet

On Error Resume Next

    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Select the cells you are working with:", "Select Range", WorkRng.Address, Type:=8)

Set ws = Worksheets.Add

WorkRng.Copy

For Each Rng In WorkRng

If Rng.Value < 30 Then
        Rng.Value = "< 30"

    End If
Next

With ws.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteValuesAndNumberFormats
End With

ws.Columns("A").AutoFit

Application.CopyCutMode = False

End Sub

它当前复制所选范围并使用抑制值更新原始数据源和新工作表。如何防止它修改原始数据而只转换复制的数据？

标签： excelvba

解决方案

试试这个：

Sub SuppressLessThan()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim Rng As Range
    Dim WorkRng As Range
    Dim dTargetNum As Double
    Dim sDefault As String

    dTargetNum = 30

    If TypeName(Selection) = "Range" Then sDefault = Selection.Address
    On Error Resume Next
    Set WorkRng = Application.InputBox("Select the cells you are working with:", "Select Range", sDefault, Type:=8)
    On Error GoTo 0
    If WorkRng Is Nothing Then Exit Sub 'Pressed cancel

    Set wb = WorkRng.Worksheet.Parent
    Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))

    WorkRng.Copy
    ws.Range("A1").PasteSpecial xlPasteValues
    ws.Range("A1").PasteSpecial xlPasteFormats
    ws.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False

    For Each Rng In ws.UsedRange.Cells
        If Rng.Value < dTargetNum Then Rng.Value = "< " & dTargetNum
    Next Rng

    ws.UsedRange.EntireColumn.AutoFit

End Sub

推荐阅读