Public Connections As Collection
' коллекция Connections содержит какие-то объекты, каждый объект - подключение к одному из файлов
' но только чтобы эта коллекция подключений не занимала кучу памяти в Excel


Function GetValue(ByVal key$, ByVal filename$) As String
    ' подключается к файлу filename$ (если подключение требуется, и ранее не установлено)
    ' ищет в нём ключ key$, и возвращает значение, соответствующее ключу
End Function

Sub SetValue(ByVal key$, ByVal value$, ByVal filename$)
    ' подключается к файлу filename$ (если подключение требуется, и ранее не установлено)
    ' и добавляет к нему запись key$|value$
End Sub

Sub test1()
    With UserForm1
        .Show
    End With
End Sub

Sub test2()
    With New UserForm1
        .Show
    End With
End Sub

Sub test_WMI()
    On Error Resume Next: Err.Clear
    Dim obj As Object, DriveID$, PartName$, t As Double: t = Timer
    With GetObject("winmgmts:{impersonationLevel=Impersonate}!//.")
        For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID='" & Environ("SystemDrive") & "'} WHERE AssocClass = Win32_LogicalDiskToPartition"): PartName$ = obj.DeviceID: Next
        For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & PartName$ & "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"): DriveID$ = obj.DeviceID: Next
        For Each obj In .ExecQuery("SELECT * FROM Win32_DiskDrive WHERE DeviceID='" & Replace(DriveID$, "\", "\\") & "'"): Debug.Print obj.Caption, obj.Signature: Next
        For Each obj In .ExecQuery("SELECT * FROM Win32_BaseBoard"): Debug.Print "Материнская плата: " & obj.SerialNumber: Next
        Debug.Print "Partition = " & PartName$, "DriveID = " & DriveID$: Debug.Print "time = " & Format(Timer - t, "0.00 сек.")
        If Err Then Debug.Print "error " & Err.Number, Err.Description
    End With
End Sub 

=СМЕЩ(RC;0;2-ОСТАТ(СТОЛБЕЦ();3);1;1)=списки!R8C4

' sh - кодовое имя листа

Sub test1()
    a = FIOarray1 ' Excel 2007 и 2010 молча закрываются, Excel 2003 зависает
End Sub

Sub test2()
    a = FIOarray2 ' все нормально работает
End Sub

Function FIOarray1() As Variant ' Excel глючит
    ' возвращает двумерный массив с фамилиями и примечаниями к ним
    Dim cell As Range, n&
    FIOarray1 = FIOrange.Resize(, 2).Value
    For Each cell In FIOrange.Cells
        n = n + 1: FIOarray1(n, 2) = cell.NoteText
    Next cell
End Function

Function FIOarray2() As Variant ' а вот так - работает
    ' возвращает двумерный массив с фамилиями и примечаниями к ним
    Dim cell As Range, n&: arr = FIOrange.Resize(, 2).Value
    For Each cell In FIOrange.Cells
        n = n + 1: arr(n, 2) = cell.NoteText
    Next cell
    FIOarray2 = arr
End Function


Function FIOrange() As Range
    Set FIOrange = sh.Range(sh.[b5], sh.Range("b" & sh.Rows.Count).End(xlUp))
End F unction

Function ВставитьКартинку(ByRef cell As Range, ByVal Pic As String) As Boolean   
    ' если картинка вставлена успешно, возвращает TRUE   
    On Error Resume Next: Err.Clear   
    Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)   
    ВставитьКартинку = Err.Number = 0   
    ph.Top = cell.Top: ph.Left = cell.Left: k = ph.Width / ph.Height   
    ph.Width = cell.Width: ph.Height = ph.Width / k   
    cell.EntireRow.RowHeight = ph.Height   
End Function   

ph.Top = cell.Top: ph.Left = cell.Left