Программно изменить содержимое в ячейке Excel - PullRequest
0 голосов
/ 22 марта 2020

Ниже приведено требование к достижению в Excel с помощью программы VBA

Пользователь вводит интервал времени в минутах, например, 30: 30 минут.

Когда пользователь убирает фокус с ячейка, содержимое в ячейке должно измениться на почасовой формат. В этом случае это значение равно .50, поскольку 30 минут эквивалентны .50 часам.

Если пользователь сохраняет фокусировку на этой ячейке, содержимое ячейки должно снова измениться на 30. И если пользователь перемещает фокус за пределы этой ячейки, содержимое ячейки должно снова измениться на .50. Тот же процесс должен повторяться до тех пор, пока пользователь перемещает фокус в или из этой ячейки.

Вот мой текущий код. Но этот код работает только один раз. Если я перемещаю фокус за пределы ячейки или внутри ячейки во второй раз, он не работает.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Set JanRange = Sheet2020.Range(Cells(2, 1), Cells(2, 31))
    Set FebRange = Sheet2020.Range(Cells(4, 1), Cells(4, 28))
    Set MarRange = Sheet2020.Range(Cells(6, 1), Cells(6, 31))
    Set AprRange = Sheet2020.Range(Cells(8, 1), Cells(8, 30))
    Set MayRange = Sheet2020.Range(Cells(10, 1), Cells(10, 31))
    Set JunRange = Sheet2020.Range(Cells(12, 1), Cells(12, 30))
    Set JulRange = Sheet2020.Range(Cells(14, 1), Cells(14, 31))
    Set AugRange = Sheet2020.Range(Cells(16, 1), Cells(16, 31))
    Set SepRange = Sheet2020.Range(Cells(18, 1), Cells(18, 30))
    Set OctRange = Sheet2020.Range(Cells(20, 1), Cells(20, 31))
    Set NovRange = Sheet2020.Range(Cells(22, 1), Cells(22, 30))
    Set DecRange = Sheet2020.Range(Cells(24, 1), Cells(24, 31))
    Set DivRg = Application.Union(JanRange, FebRange, MarRange, AprRange, MayRange, JunRange, JulRange, AugRange, SepRange, OctRange, NovRange, DecRange)

    Dim iSect As Range
    Set iSect = Application.Intersect(Target, DivRg) 'Here, iSect gives me the value in the cell
    'MsgBox "From Worksheet_SelectionChange" & iSect
    If Not (iSect Is Nothing) And (iSect < 2#) Then
        Application.EnableEvents = False
        iSect = iSect * 60
        If (iSect = 0) Then iSect = Empty
        Application.EnableEvents = True
        ElseIf Not (iSect Is Nothing) And (iSect = 2#) Then
        'MsgBox "From Worksheet_SelectionChange, Please color code this cell"
        iSect.Interior.Color = vbYellow
        iSect.Font.Color = vbBlack
    End If
    Set DivRg = Nothing
End Sub

Как я могу изменить код для удовлетворения этому требованию несколько раз?

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...