Необходимо увеличить значение 1 на 1 в активной ячейке в пределах диапазона - PullRequest
0 голосов
/ 26 января 2020
Sub Macro5()
  Dim rng As Range
    Set rng = Selection
      For Each cell In rng
        ActiveCell.Value = ActiveCell.Value + 1
     Next
End Sub

Ответы [ 2 ]

2 голосов
/ 26 января 2020

Быстрое исправление для вашего кода будет

Sub Macro5()
    Dim rng As Range
    Set rng = Range("B2:B10")
    Dim cell As Range
    For Each cell In rng
        cell.Value = cell.Value + 1
    Next
End Sub

Обновление : По комментарию, я думаю, вы хотели бы использовать событие SelectionChange. Поместите следующий код в модуль кода листа

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    On Error GoTo EH
    Application.EnableEvents = False

    Dim rg As Range
    Set rg = Range("B2:B12")

    If Not (Intersect(rg, Target) Is Nothing) Then
        Dim sngCell As Range
        ' This will only increase the values of the selected cells within B2:B10
        ' Not sure if this is wanted. Otherwise just modify according to your needs
        For Each sngCell In Intersect(Target, rg)
            sngCell.Value = sngCell.Value + 1
        Next sngCell
    End If

EH:
    Application.EnableEvents = True
End Sub

Обновление 2 : если вы хотите запустить код с помощью кнопки, вставьте следующий код в стандартный модуль и назначьте его на кнопку, которую вы создаете на листе

Sub Increase()

    On Error GoTo EH
    Application.EnableEvents = False

    Dim rg As Range
    Set rg = Range("B2:B10")

    If Not (Intersect(rg, Selection) Is Nothing) Then
        Dim sngCell As Range
        For Each sngCell In Intersect(Selection, rg)
            sngCell.Value = sngCell.Value + 1
        Next sngCell
    End If

EH:
    Application.EnableEvents = True
End Sub
0 голосов
/ 26 января 2020

Проверьте, находится ли текущая ячейка в пределах вашего диапазона!

Sub Macro5()
  Dim rng As Range
  Dim fixed_rng As Range
  Set rng = Selection
  Set fixed_rng = Range("B1:B10")
  if Application.Union(rng, fixed_rng) = fixed_rng then
    For Each cell In rng
      ActiveCell.Value = ActiveCell.Value + 1
    Next
  End If
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...