Сценарий Excel VBA - воровство фокуса

Question

Я работаю над сценарием, который периодически пингует компьютеры из списка и возвращает информацию.

Моя проблема в том, что всякий раз, когда скрипт запускается, он крадет фокус у другого excel windows.
Например, если при вводе скрипта я печатаю другую книгу, он переходит на ячейка, которая была выбрана последней) и продолжает запись в ячейку.

Вот сценарий:

Sub autoping_cb()

Dim c As Range
Dim thePing As Variant
Dim TryCount As Integer
Dim TryAgainCount As Integer
Dim TryNextRun As Boolean

TryNextRun = False

Set sht = Application.ThisWorkbook.Worksheets(1)
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row

Dim chb As Shape
Set chb = ThisWorkbook.Worksheets(1).Shapes("autoping")

If chb.ControlFormat.Value = xlOn Then



sht.Range("H3").Value = Replace(sht.Range("H3").Value, ",", ".")


TryCount = 1

    If sht.Range("H4") <> "" And IsNumeric(sht.Range("H4")) = True And sht.Range("H4") = Int(sht.Range("H4")) And sht.Range("H3") <> "" And IsNumeric(sht.Range("H3")) = True Then
        TryAgainCount = sht.Range("H4").Value
            If TryAgainCount = 0 Then
                TryNextRun = True
            End If
        Do Until chb.ControlFormat.Value = xlOff            


            Wait ThisWorkbook.Worksheets(1).Range("H3").Value * 60 '<-- replace to 60 after testing

            For Each c In Application.Worksheets(1).Range("B3:B" & LastRow)
                    If chb.ControlFormat.Value = xlOff Then
                        End

                    ElseIf chb.ControlFormat.Value = xlOn Then
                        If ispcname(c.Value) = True Or isip(c.Value) = True Then
                            If c.Offset(0, 2) = "--->" And TryNextRun = False Then



                            Else
                                c.Offset(0, 1) = nslookup(c.Value)
                                thePing = sPing(c.Value)
                                c.Offset(0, 2) = thePing(0)
                                c.Offset(0, 3) = GetErrorCode(thePing(1))

                                If c.Offset(0, 2).Value = "--->" Then
                                    sht.Range("B" & c.Row & ":E" & c.Row).Style = "Bad"
                                ElseIf c.Offset(0, 2).Value < 50 Then
                                    sht.Range("B" & c.Row & ":E" & c.Row).Style = "Good"
                                Else
                                    sht.Range("B" & c.Row & ":E" & c.Row).Style = "Neutral"
                                End If

                            End If
                        End If


                    End If



                sht.Range("B2:E" & LastRow + 1).Columns.AutoFit
            Next c

        If TryNextRun = False And TryCount < TryAgainCount Then
            TryCount = TryCount + 1
            Debug.Print 1
        ElseIf TryNextRun = False And TryCount >= TryAgainCount Then
            TryNextRun = True
            TryCount = 1
            Debug.Print 2
        ElseIf TryNextRun = True And TryAgainCount <> 0 Then
            TryNextRun = False
            Debug.Print 3
        End If


        Loop

    Else
        MsgBox "invalid 'Ping every'/'try offline after' integer"
    End If

End If

End Sub

Это немного грязно, я знаю: -)

Answer 1

Я думаю, что самое простое решение - использовать задачу-планировщик и запустить свой макрос оттуда. В свойствах расширения выберите «запускать, вошел ли пользователь в систему или нет», тогда это запускается в отдельной задаче.

Answer 2

Поскольку все листы Excel работают в одном потоке (один экземпляр Excel.exe, вы можете видеть одно присутствие в диспетчере задач).

Если вы работаете с большим количеством экземпляров Excel, ваш лист работает независимо.

Вы можете воспользоваться одной из следующих возможностей:

- просто открыть новый Excel.exe из меню «Пуск», значок и т. Д. c

- windows значок Excel Excel справа нажмите, затем alt + нажмите на Microsoft Excel

-start команду (или ярлык или пакетный файл): Excel.exe «путь xls» / x

-vba

Sub OpenNewExcelInstance()

Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
xlApp.Workbooks.Add
xlApp.Visible = True
Set xlApp = Nothing

End Sub

- измените реестр, чтобы принудительно открыть его в новом экземпляре

- измените свой Personal.xlsb