Форум по VBA и MS Office

Option Explicit

Sub Выбор_файла()

    'Перед переменными и константами лучше добавлять префикс,
    'чтобы имя переменной или константы не совпало с зарезирвированным словом.
    'Я добавляю префикс в зависимости от типа данных.
    'В данном случае добавил префикс "s".   
    Dim sFilePath As String
    Dim sFileName As String
    Dim sFormula As String
   
    sFilePath = GetFilePath
   
    If sFilePath = "" Then Exit Sub
   
    MsgBox sFilePath

    'Получаем имя книги.
    sFileName = Mid(sFilePath, InStrRev(sFilePath, "\") + 1)
   
    'Получаем путь к книге.
    sFilePath = Mid(sFilePath, 1, InStrRev(sFilePath, "\"))
   
    'Формируем общую часть для всех формул.
    sFormula = "='" & sFilePath & "[" & sFileName & "]Анализ'!"
   
    Range("D10").FormulaR1C1 = sFormula & "R11C4"
    Range("D11").FormulaR1C1 = sFormula & "R12C4"

End Sub

Public Function GetFilePath() As String
   
    Const sTitle As String = "Выберите файл КДРО"
    Const sInitialPath As String = "c:\"
    Const sFilterDescription As String = "Книги Excel"
    Const sFilterExtention As String = "*.xls*"
   
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = sTitle: .InitialFileName = sInitialPath
        .Filters.Clear: .Filters.Add sFilterDescription, sFilterExtention
       
        If .Show = 0 Then Exit Function
       
        GetFilePath = .SelectedItems(1)
       
    End With
   
End Function

Sub Программа()
   
    Dim shSrc As Worksheet, arrSrc()
    Dim shRes As Worksheet, arrRes(), r As Long
    Dim strFN_src As String
    Dim lr As Long, i As Long
   
   
    '1. Юзер выбирает файл-источник.
    strFN_src = GetFilePath
    If strFN_src = "" Then Exit Sub
   
    '2. Отключение монитора, чтобы ускорить работу макроса и чтобы меньше мигало.
    Application.ScreenUpdating = False
   
    '3. Присваивание листу-результату имени "shRes". Затем через это имя удобно обращаться к листу в коде.
    Set shRes = ActiveSheet
   
    '4. Открытие файла-источника.
        ' Листу "свод" присваивается имя "shSrc".
        ' ReadOnly:=True - нам нужно открыть только для чтения. Это может чем-нибудь упростить макрос.
    Set shSrc = Workbooks.Open(Filename:=strFN_src, ReadOnly:=True).Worksheets("свод")
   
    '5. Копирование некоторых данных из листа-источника в массив. С массивом быстрее работать, чем с эксель-ячейками.
        ' На листе не должно быть скрытых строк, иначе некоторые строки могут быть не учтены.
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arrSrc() = shSrc.Range("A1:C" & lr).Value
   
    '6. Создание ячеек в массиве-результате. Сначала в него запишутся данные, а затем он
        ' будет вставлен на эксель-лист. Это ускорит работу макроса.
        ' Строк создаётся максимально возможное кол-во, т.к. заранее не известно, сколько будет строк с данными.
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 3)
   
    '7. Копирование данных из листа-источника в массив-результат.
    For i = 5 To UBound(arrSrc, 1)
        If (arrSrc(i, 1) = 1) And (arrSrc(i, 3) = "ВСЕГО") Then
            r = r + 1
            arrRes(r, 1) = arrSrc(i, 1)
            arrRes(r, 2) = arrSrc(i, 2)
            arrRes(r, 3) = shSrc.Cells(i, "P").Value
        End If
    Next i
   
    '8. Закрытие файла-источника.
    shSrc.Parent.Close SaveChanges:=False
   
    '9. Действия, если не было найдено нужных строк.
    If r = 0 Then
        Application.ScreenUpdating = True
        MsgBox "В файле-источнике нет нужных данных.", vbExclamation
        Exit Sub
    End If
   
    '10. Вставка данных на лист-результат.
    shRes.Range("A3").Resize(r, UBound(arrRes, 2)).Value = arrRes()
   
    '11. Включение монитора.
    Application.ScreenUpdating = True
   
    '12. Сообщение, чтобы было понятно, что программа завершила работу.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Function GetFilePath() As String
   
    Const sTitle As String = "Выберите файл КДРО"
    Const sInitialPath As String = "c:\"
    Const sFilterDescription As String = "Книги Excel"
    Const sFilterExtention As String = "*.xls*"
   
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = sTitle: .InitialFileName = sInitialPath
        .Filters.Clear: .Filters.Add sFilterDescription, sFilterExtention
       
        If .Show = 0 Then Exit Function
       
        GetFilePath = .SelectedItems(1)
       
    End With
   
End Function