Макрос: ошибка 400

[gitzzz]

Здравствуйте!
При запуске макроса вылетает окошко с надписью "Ошибка 400". Как "ни крутил" с кодом, так и не понял в чем проблема...Подскажите, пожалуйста, с чем я столкнулся. Вот код макроса. В файле визуализация ошибки.

Sub Find_Value()
    Dim iFoundRng As Range, iRange As Range, rCell As Range
    Dim lLastCell As Long
    Dim sWB As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "??????? ???? ??? ??????????? ????????"
        .InitialFileName = "*.*"
        If .Show = False Then Exit Sub
        sWB = Dir(.SelectedItems(1), vbDirectory)
        On Error Resume Next
        Workbooks(sWB).Activate
        If Err.Number > 0 Then Workbooks.Open .SelectedItems(1)
        On Error GoTo 0
    End With
Application.ScreenUpdating = False
    
lLastCell = Workbooks.Application.Sheets(1).Columns(4).Cells(Rows.Count, 1).End(xlUp).Row
Set iRange = Workbooks.Application.Sheets(1).Columns(4).Range(Cells(23, 4), Cells(lLastCell, 4))
      
    For Each rCell In iRange
        With ThisWorkbook.Sheets(1)
            Set iFoundRng = .Columns(4).Find(rCell.Value)
            If Not iFoundRng Is Nothing Then
                
              iFoundRng.Offset(0, 2).Value = iFoundRng.Offset(0, 2).Value + rCell.Offset(0, 5).Value
              
            End If
        End With
    Next rCell
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub

[EducatedFool]

Попробуйте так:

Sub Find_Value()
    Dim iFoundRng As Range, iRange As Range, rCell As Range
    Dim lLastCell As Long
    Dim sWB As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "??????? ???? ??? ??????????? ????????"
        .InitialFileName = "*.*"
        If .Show = False Then Exit Sub
        sWB = Dir(.SelectedItems(1), vbDirectory)
        On Error Resume Next
        Workbooks(sWB).Activate
        If Err.Number > 0 Then Workbooks.Open .SelectedItems(1)
        On Error GoTo 0
    End With
    Application.ScreenUpdating = False

    lLastCell = Sheets(1).Columns(4).Cells(Rows.Count, 1).End(xlUp).Row
    Set iRange = Sheets(1).Range(Sheets(1).Cells(23, 4), Sheets(1).Cells(lLastCell, 4))

    For Each rCell In iRange
        With ThisWorkbook.Sheets(1)
            Set iFoundRng = .Columns(4).Find(rCell.Value)
            If Not iFoundRng Is Nothing Then
                iFoundRng.Offset(0, 2).Value = iFoundRng.Offset(0, 2).Value + rCell.Offset(0, 5).Value
            End If
        End With
    Next rCell
    ThisWorkbook.Activate
End Sub

И то, не факт, что этот код будет работать в Excel 2007 - там отключен используемый Вами метод Application.FileDialog



Чтобы всё работало (в том числе и в Excel 2007), надо использовать другой способ выбора файла - вместо FileDialog применять GetOpenFileName