Мои два макроса "конфликтуют", т.е. они не могут работать одновременно - PullRequest
1 голос
/ 17 мая 2019

Фон

У меня есть 2 макроса в одной из моих таблиц, которые i) получают цену предыдущего закрытия с веб-сайта Bloomberg прямо на лист [запускается кнопкой] (ячейки H3:вниз) и ii) другой регистрирует метку времени, если это новое значение вызывает изменение формулы, расположенной в ячейках K3: вниз.Затем, если есть какое-либо изменение, время, в которое это произошло, будет зарегистрировано в столбцах справа от столбца H.

Моя проблема заключается в том, что когда я нажимаю кнопку, чтобы запустить Macro i),Отладчик выскакивает «Ошибка времени выполнения 1004. Метод« отменить »Object'_application« не удалось », что привело к прекращению работы макроса ii) (т. е. прекращение регистрации времени, в течение которого произошло изменение значения в интересующем столбце).Строка кода, выделенная отладчиком: «Application.undo»

Если честно, я немного растерялся в процессе.

Это код

Отказ от ответственности: большинство комментариев посвящено тому, как на самом деле работает код.Большое спасибо всем, кто внес вклад в оба подпункта.

Private Sub Worksheet_Calculate()

    Dim rMonitored As Range
    Dim MonitoredCell As Range
    Dim vSelected As Variant
    Dim aNewValues As Variant
    Dim ixFormulaCell As Long

    On Error Resume Next
    Set rMonitored = Me.Columns("K").SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If rMonitored Is Nothing Then Exit Sub  'No formula cells in column K

    Application.EnableEvents = False    'Disable events to prevent infinite calc loop
    Set vSelected = Selection           'Remember current selection (it may not be a range)

    'Prepare the array that will store the new values, the cells those values are in, and whether or not there was a change
    ReDim aNewValues(1 To rMonitored.Cells.Count, 1 To 3)
        'Column1 = new value
        'Column2 = cell address
        'Column3 = did value change?

    'Get the new value for each formula in column K
    ixFormulaCell = 0
    For Each MonitoredCell In rMonitored.Cells  'The formula cells may not be in a contiguous range
        ixFormulaCell = ixFormulaCell + 1
        aNewValues(ixFormulaCell, 1) = MonitoredCell.Value  'Store the new value
        Set aNewValues(ixFormulaCell, 2) = MonitoredCell    'Store the cell address
    Next MonitoredCell

    Application.Undo    'This will undo the most recent change, which allows us to compare the new vs old to check for formula updates

    ixFormulaCell = 0
    For Each MonitoredCell In rMonitored.Cells
        ixFormulaCell = ixFormulaCell + 1
        'Check if the formula result is different
        If MonitoredCell.Value <> aNewValues(ixFormulaCell, 1) Then
            'Formula result found to be different, record that
            'We can't put the timestamp in now because we still have to redo the most recent change
            aNewValues(ixFormulaCell, 3) = True
        End If
    Next MonitoredCell

    Application.Undo    'Redo the most recent change to put worksheet back in the new state
    '--> THE LINE OF CODE ABOVE IS WHAT THE DEBUGGER POINTS TO

    'Now that we've completed our comparison and have re-done the most recent change, check what did change and put in a timestamp in the next empty cell in same row
    For ixFormulaCell = LBound(aNewValues, 1) To UBound(aNewValues, 1)
        'Check for formula result change
        If aNewValues(ixFormulaCell, 3) Then
            'Formula result change found, get next empty cell in same row
            With Me.Cells(aNewValues(ixFormulaCell, 2).Row, Me.Columns.Count).End(xlToLeft).Offset(, 1)
                'Next empty cell found, put in the current datetime stamp and format it
                .Value = Now
                .NumberFormat = "dd-mm-yyyy, hh:mm:ss"
                .HorizontalAlignment = xlGeneral
                .VerticalAlignment = xlCenter
            End With
        End If
    Next ixFormulaCell

    vSelected.Select                'Re-select the remembered selection so that this operation is invisible to users
    Application.EnableEvents = True 'Re-enable events so that the next calculation can be monitored for formula changes in cells of interest

End Sub
Public Sub test()

    Dim re As Object, pairs(), ws As Worksheet, i As Long, s As String
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set re = CreateObject("VBScript.RegExp")

    With ws
        pairs = Application.Transpose(.Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Value) ' assumes pairs start in row 3
    End With

    Dim results()
    ReDim results(1 To UBound(pairs))

    With CreateObject("MSXML2.XMLHTTP")
        For i = LBound(pairs) To UBound(pairs)
            .Open "GET", "https://www.bloomberg.com/quote/" & pairs(i) & ":CUR", False
            .send
            s = .responseText
            results(i) = GetCloseValue(re, s, "previousClosingPriceOneTradingDayAgo%22%3A(.*?)%2")
        Next
    End With

    ws.Cells(3, "I").Resize(UBound(results), 1) = Application.Transpose(results)

End Sub
Public Function GetCloseValue(ByVal re As Object, inputString As String, ByVal pattern As String) As String 'https://regex101.com/r/OAyq30/1

    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .pattern = pattern

        If .test(inputString) Then
            GetCloseValue = .Execute(inputString)(0).SubMatches(0)
        Else
            GetCloseValue = "Not found"
        End If

    End With

End Function

Ожидаемый результат

Я бы хотел, чтобы оба макроса работали одновременно.

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