Nhờ sửa code tự động trừ đi một giá trị trong vùng được chọn

[ohlexus]

Chào các bạn
Mình có tạo 1 cái code để tự trừ đi 1 giá trị, cụ thể là 100 đơn vị trong các ô đã chọn.
Nhưng với code mình tạo thì gặp các vấn đề sau, nhờ Anh em khắc phục giúp.
- Khi chọn lớn hơn 2 ô thì code chạy được
- Khi Chọn 1 ô ở bất kỳ đâu trong bảng mà chạy code thì toàn bộ vùng có dữ liệu đều chạy lệnh đều bị trừ đi 100 đơn vị.
Mình chỉ muốn các ô/ vùng được chọn mới có tác dụng khi chạy lệnh (kể cả chọn 1 ô), không chạy lệnh được khi ô chọn không có giá trị số.
Và sau khi chạy lệnh có thể sử dụng được chức năng Undo (Ctr+Z) như việc nhập số thông thường, hiện tại mình chạy lệnh thì không Undo được.
Mình chép code sau vào Module, và có sử dụng phím tắt để gọi lệnh.

Sub SubtractTenFromSelectedArea()
    Dim rng As Range
    Dim cell As Range
    Dim oldValue As Variant
    Dim newValue As Variant

    ' Get the selected range
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0

    ' Check if any range is selected
    If Not rng Is Nothing Then
        Application.ScreenUpdating = False

        ' Loop through each cell in the selected range
        For Each cell In rng
            oldValue = cell.Value
            ' Subtract 100 units if the cell contains a numeric value
            If IsNumeric(oldValue) Then
                newValue = oldValue - 100
                cell.Value = newValue
            End If
        Next cell

        Application.ScreenUpdating = True
    Else
        MsgBox "Please select a range containing numeric values to subtract 100 units.", vbExclamation
    End If
End Sub

 

[ohlexus]

Mình sử dụng code sau thì cũng gặp tình trạng tương tự như trên

Sub PasteSpecialSubtract100()
    Dim rng As Range
    Dim oldValue As Variant
    Dim newValue As Variant
    
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0
    
    If Not rng Is Nothing Then
        Application.ScreenUpdating = False
        
        For Each cell In rng
            oldValue = cell.Value
            If IsNumeric(oldValue) Then
                newValue = oldValue - 100
                cell.Value = newValue
            End If
        Next cell
        
        Application.ScreenUpdating = True
    Else
        MsgBox "Please select a range containing numeric values to subtract 100.", vbExclamation
    End If
End Sub

 

[Phuocam]

Và sau khi chạy lệnh có thể sử dụng được chức năng Undo (Ctr+Z) như việc nhập số thông thường, hiện tại mình chạy lệnh thì không Undo được.

Set rng = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)

1. Thử thay: Set rng = Selection .SpecialCells(xlCellTypeConstants, xlNumbers)

bằng: Set rng = Selection

2. Không Undo được. Thử viết thêm 1 sub (Cộng100) xem sao.

.

 

[ohlexus]

Thay Set rng = Selection thì lệnh chạy được được như ý rồi bạn nhé. Cảm ơn bạn.
Nếu muốn khi chọn ở vùng/ ô trống, không có dữ liệu thì lệnh không được chạy thì cần thêm gì vào lệnh bạn nhỉ.
Viết thêm 1 sub (Cộng100) thì khi ấy lại phải chọn lại vùng cần Undo, có cách nào để Undo như thông thường của excell không bạn nhỉ,

 

[bebo021999]

Dùng thử code này xem sao

Option Explicit
Dim i&, k&, preVal(), c As Boolean
Sub AddValue()
Dim cell As Range
Const num = 100: c = False
ReDim preVal(1 To 100000, 1 To 3)
For Each cell In Selection
    If IsNumeric(cell) And cell <> "" Then
        k = k + 1
        preVal(k, 1) = cell.Row
        preVal(k, 2) = cell.Column
        preVal(k, 3) = cell.Value
        cell.Value = cell.Value + num
    End If
Next
If k > 0 Then c = True
End Sub
'---------------------------
Sub UndoN()
If c Then
    For i = 1 To k
        If Not IsEmpty(preVal(i, 1)) Then Cells(preVal(i, 1), preVal(i, 2)).Value = preVal(i, 3)
    Next
Else
    MsgBox "Nothing to undo"
End If
c = False
End Sub

 

[ohlexus]

Dùng thử code này xem sao

Option Explicit
Dim i&, k&, preVal(), c As Boolean
Sub AddValue()
Dim cell As Range
Const num = 100: c = False
ReDim preVal(1 To 100000, 1 To 3)
For Each cell In Selection
    If IsNumeric(cell) And cell <> "" Then
        k = k + 1
        preVal(k, 1) = cell.Row
        preVal(k, 2) = cell.Column
        preVal(k, 3) = cell.Value
        cell.Value = cell.Value + num
    End If
Next
If k > 0 Then c = True
End Sub
'---------------------------
Sub UndoN()
If c Then
    For i = 1 To k
        If Not IsEmpty(preVal(i, 1)) Then Cells(preVal(i, 1), preVal(i, 2)).Value = preVal(i, 3)
    Next
Else
    MsgBox "Nothing to undo"
End If
c = False
End Sub

Cám ơn bạn, để mình chạy thử