Подавить значения под "X" и скопировать на новый лист

Question

Я пытаюсь создать шаблон VBA, который можно использовать для подавления всех значений данных на определенную величину.Я нашел / обновил некоторый код, который я нашел в Интернете, который успешно создает новый лист, передает выбранные данные и заменяет все числовые значения 30 и ниже на «<30», как требуется.Однако он также обновляет исходный источник данных, заменяя выбранные данные, а не только обновляя данные на новом листе.Как я могу предотвратить изменение исходных данных и только изменение данных, скопированных на новый лист? </p>

Я попробовал этот код здесь, но не получил желаемых результатов и не смог выяснить, какчтобы изменить его, чтобы достичь их:

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

В настоящее время он копирует выбранный диапазон и обновляет исходный источник данных и новый лист с подавленными значениями.Как я могу предотвратить изменение исходных данных и преобразовать только скопированные данные?

Answer 1

Попробуйте:

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