Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("J:J")) Is Nothing Then
Call Mymacro
End If
End Sub

Shell "cmd /c copy """ & updFilePath & updFileArr(i) & """, """ & fnSyn & """"
    Application.Wait Now + TimeSerial(0, 0, 10)

pRSet.Open "Select `id` from dog_tb WHERE `sn`=" & obArr(i_db, 3), pConn, adOpenStatic, adLockOptimistic
rrrr = pRSet.Fields.Item(0).Value
    If pRSet.EOF = False Then
        'изменение поля записи
        pRSet.Close
        pRSet.Open "Select * from dog_tb", pConn, adOpenStatic, adLockOptimistic
        pRSet.MoveFirst
        pRSet.Find "id=" & rrrr & Chr(34), 0, adSearchForward
        pRSet("log_time") = Now
        pRSet.Update
    End If

Select Case t7Arr(t, 4)
    Case Is = "R" And bArr(f,4) <> "ОТС" <------------- ошибка Type Mismatch

Sub text()

nomArr = Range("A3:E125") ' таблица соответсвия
Open "пульты.ned" For Input As #1

    Dim s As String
    While Not EOF(1)
        Input #1, s
        If Mid(Trim(Replace(s, " ", "")), 2, 13) = Chr(34) & "ownerName" & Chr(34) & ":" & Chr(34) Then
            iDn = Mid(Trim(Replace(s, " ", "")), 15, Len(Trim(Replace(s, " ", ""))) - 15)
            For i = 1 To UBound(nomArr)
                If iDn = CStr(nomArr(i, 3)) And nomArr(i, 4) <> "" Then
                    iNomer = nomArr(i, 4)
                    s = Replace(s, iDn, iNomer)
                    Print #1, s ' <---------------------------------- вот тут возникает затык
                End If
            Next i
            
        End If
    Wend
  Close #1
End Sub

{
    "configs": [
        {
            "config_list": [
                {
                    "devices": [
                        {
                            "active": true,
                            "group": 1,
                            "id": 39173,
                            "ownerName": "39173",
                            "scriptAction": 0,
                            "system": 2,
                            "workMode": 0
                        },
                        {
                            "active": true,
                            "group": 1,
                            "id": 192260,
                            "ownerName": "192260",
                            "scriptAction": 0,
                            "system": 2,
                            "workMode": 0
                        },

If Err.Number = -2147220973 Then ermsg = "Отсутствует связь с интернетом"
        If Err.Number = -2147220975 Then ermsg = "SMTP сервер ответил отказом"
        If Err.Number = 0 Then ermsg = "Письмо отправлено"
    Send_Mail = Err = 0

Sub test()
Rows(1).Copy
Cells(1, 5) = 444
Range("2:2").PasteSpecial
End Sub

            monthBill = Format(CDate(InputBox("Введите месяц и год "Например 02.2015", "Месяц акта")), "mm.yyyy")
            monthBillArr = CStr(monthBill)
            arrName = monthBillArr & "ar"
            Dim arrName()
            ArrVSize = LastRow - FirstRow
            ReDim arrName(1 To 4, 1 To ArrVSize)

For Each ws In Worksheets

    If Left(ws.Name, 2) = "1." Then 
        ColNum = 11
        wsLastRow = ws.Cells(Rows.Count, ColNum).End(xlUp).Row
        ReDim tarArr(1 To wsLastRow - 2, 1 To 3)
        i = 0
        For Each cel In ws.Range(ws.Cells(3, 11), ws.Cells(wsLastRow, 11))
                i = i + 1
                tarArr(i, 1) = Trim(cel.Offset(0, -1).Value) & Trim(cel.Value) _
                & Trim(cel.Offset(0, -2).Value) & Trim(cel.Offset(0, 1).Value)
                tarArr(i, 2) = cel.Row
                tarArr(i, 3) = Trim(cel.Offset(0, -1).Value) & Trim(cel.Value)
            
        Next
        For j = 1 To UBound(tarArr)
        
            With Range(Sheets("Выгрузка").Cells(3, 11), Sheets("Выгрузка").Cells(bazaLastRow, 7))
                Set c = .Find(tarArr(j, 3), LookIn:=xlValues)
                'c = Trim(c)
                If Not c Is Nothing Then
                firstAddress = c.Address

For Each ws In Worksheets
    If Left(ws.Name, 2) = "1." Then 
        
        firstCel = Cells(3, 11)       'определяем первую и последнюю строку диапазона
        firstCelCol = Range(firstCel).Column
        LastRow = Cells(Rows.Count, firstCelCol).End(xlUp).Row
        For Each cel In Range(firstCel, LastRow)
                With Range(firstCel, LastRow)
                Set c = .Find(cel, LookIn:=xlValues)
                If Not c Is Nothing Then
                firstAddress = c.Address
                    Do
                        c.Offset(0, 19) = "Повторяется на "  'имя листа ' адрес ячейки
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
                End With
        Next
    
    End If

ActiveDocument.Range(Start:=ActiveDocument.Range.Start, End:=ActiveDocument.Range.End).Copy
Selection.EndKey Unit:=wdStory
Selection.InsertBreak Type:=wdPageBreak
Selection.Paste
ActiveDocument.Range(Start:=ActiveDocument.Range.Start, End:=ActiveDocument.Range.Start).Select
Selection.InsertBreak Type:=wdPageBreak

With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(1.27)
        .BottomMargin = CentimetersToPoints(1)
        .LeftMargin = CentimetersToPoints(2.4)
        .RightMargin = CentimetersToPoints(0.95)

Set objWordBill = CreateObject("Word.Application")
            objWordBill.Visible = True
            directory = fnShellBrowseForFolderVB1 & "\"
            objWordBill.Documents.Open (directory & fileName)
Set aDoc = objWordBill.ActiveDocument