Developing.ru

Код: Выделить всё

Private Sub Test()

    Dim iPath$, iFormula$
    
    iPath = ThisWorkbook.Worksheets(1).Range("B1")
    iFormula = "='W:\Документы\" & iPath & "\[Карточка.xlsx]Карточка'!A1"
    
    With ThisWorkbook.Worksheets(1).Range("A1")
         .Formula = iFormula
         .Value = .Value
    End With
    
End Sub

Код: Выделить всё

Private Sub Workbook_Open()
    With Application
         .ScreenUpdating = False
         .DisplayAlerts = False
         .Calculation = xlManual
    End With
    
    Dim iCell As Range
    With Me.Worksheets(1) 'ThisWorkbook.Worksheets(1)
         For Each iCell In .Range(.Cells(1, "B"), .Cells(1, "B").End(xlDown))
             With iCell.Offset(, 1)
                  .Formula = "='W:\Документы\" & iCell.Value & "\[Карточка.xlsx]Карточка'!A1"
                  .Value = .Value
             End With
         Next
    End With
    
    With Application
         .Calculation = xlAutomatic
         .DisplayAlerts = True
         .ScreenUpdating = True
    End With
End Sub

Код: Выделить всё

'http://allapi.mentalis.org/apilist/SearchTreeForFile.shtml

Private Declare Function SearchTreeForFile _
        Lib "imagehlp.dll" ( _
        ByVal RootPath As String, _
        ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long

Private Sub Test()
    With Application
         .ScreenUpdating = False
         .DisplayAlerts = False
         .Calculation = xlManual
    End With
   
    Dim iSource As Range, iCell As Range
    Dim iPath$, iFileName1$, iFileName2$, iAddress$, iCount%
    
    iPath = ThisWorkbook.Path 'Можно указать 'родительскую' папку самостоятельно
    
    With ThisWorkbook.Worksheets(1)
         Set iSource = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
         'Set iSource = .[A:A].SpecialCells(xlConstants, xlNumbers)
    End With
         
    For Each iCell In iSource
        iFileName1 = iCell & ".xlsx": iFileName2 = Space(255)
        
        If SearchTreeForFile(iPath, iFileName1, iFileName2) <> 0 Then        
           iFileName2 = Application.Trim(iFileName2)
           iFileName2 = Replace(iFileName2, iFileName1, "[" & iFileName1 & "]", , , vbTextCompare)
           
           For iCount = 1 To 3
               iAddress = Choose(iCount, "F54", "H83", "A5")
               With iCell.Offset(, iCount)
                    .Formula = "='" & iFileName2 & "Лист1'!" & iAddress
                    .Value = .Value
                    'Возможно имеет смысл заменять формулы на значения, либо
                    'сразу в трёх ячейках строки, либо вообще во 'всём' диапазоне
               End With
           Next           
        Else
           iCell.Offset(, 1).Resize(, 3) = CVErr(xlErrNA) '#Н/Д
        End If
    Next
   
    With Application
         .Calculation = xlAutomatic
         .DisplayAlerts = True
         .ScreenUpdating = True
    End With
End Sub