Авторские программы, библиотеки, надстройки и шаблоны

Function genFib() As Integer
Dim c As Integer
Dim p As Integer
Dim vbe As Object
 
 c = 0
 p = 1
    
    genFib = c + p
 
    Set vbe = ThisWorkbook.VBProject.VBComponents(2).CodeModule
    vbe.replaceLine 6, " c=" + CStr(genFib)
    vbe.replaceLine 7, " p=" + CStr(c)
 
End Function
 
Sub mk(c As Integer, p As Integer)
Dim vbe As Object
 
    Set vbe = ThisWorkbook.VBProject.VBComponents(2).CodeModule
 
    vbe.replaceLine 5, " c=" + CStr(c + p)
    vbe.replaceLine 6, " p=" + CStr(c)
 
End Sub
Sub Test()
    Debug.Print genFib
End Sub

'Adapted from http://www.robvanderwoude.com/vbstech_files_zip.html
 
'::: Получить данные из xlsx-файла book c листа sheet из заданного списка адресов
'::: без открытия книги в Excel
 
Function getValues(book As String, sheet As String, addrs As String) As Variant()
Dim Res() As Variant
Dim Typ() As Integer
 
   HomeDir$ = ThisWorkbook.Path
 
   '::: Создаем папку для распаковки
 
   tmpDir$ = HomeDir$ + "\files"
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   If objFSO.FolderExists(tmpDir$) Then
      Set tmp = objFSO.getFolder(tmpDir$)
      tmp.Delete
   End If
   objFSO.CreateFolder (tmpDir$)
 
   '::: Распаковываем содержимое xlsx-файла
   '::: Переименовываем в ".zip"
 
   newName = Replace(book, ".xlsx", ".zip")
   dest = tmpDir$
   Name book As newName
 
   '::: Распаковываем zip-архив
 
   UnZipFile newName, dest
   
   '::: Возвращаем исходное имя
   
   Name newName As book
 
   '::: Парсим список адресов
   
   alist = Split(addrs, ",")
   
   '::: Открываем файл нужного листа
   
   fi% = FreeFile
  
   Open tmpDir$ + "\xl\worksheets\" + sheet + ".xml" For Binary Access Read As #fi%
 
   '::: Загружаем в память
 
   l& = LOF(fi%)
   Buf$ = Space$(l&)
   Get #fi%, , Buf$
   Close #fi%
 
   '::: Пробегаем по адресам...
 
   n% = UBound(alist)
   
   ReDim Res(0 To n%) As Variant
   ReDim Typ(0 To n%) As Integer
 
   scount% = 0
 
   For i% = 0 To n%
   
       ctag$ = "<c r=""" + alist(i%) + """"
       
       '::: Ищем тэг начала ячейки
       
       pt& = InStr(Buf$, ctag$)
       
       If pt& > 0 Then '::: Нашли
       
          pe& = InStr(pt& + 1, Buf, "</c>")
       
          cr_tag$ = Mid$(Buf$, pt&, pe& - pt&)
       
          '::: Если тип данных строка - установим признак
          '::: и увеличим счетчик строк
          
          If InStr(cr_tag$, "t=""s""") <> 0 Then
             Typ(i%) = 1
             scount% = scount% + 1
          End If
       
          '::: Начало и конец тэга данных
       
          lctag& = Len(ctag$)
          PVB& = InStr(pt& + lctag& - 1, Buf$, "<v>")
          PVE& = InStr(pt& + lctag& - 1, Buf$, "</v>")
          
          '::: Заносим значение или номер строки
          
          Res(i%) = Mid$(Buf$, PVB& + 3, PVE& - PVB& - 3)
       
       End If
   
   Next i%
 
   '::: Если были строки...
   
   If scount% > 0 Then
   
      '::: Открываем файл строк
   
      fi% = FreeFile
   
      Open tmpDir$ + "\xl\SharedStrings.xml" For Binary Access Read As #fi%
 
      '::: Загружаем в память
 
      l& = LOF(fi%)
      Buf$ = Space$(l&)
      Get #fi%, , Buf$
      Close #fi%
   
      For i% = 0 To n%
      
          '::: Если тип очередной ячейки - строка...
      
          If Typ(i%) = 1 Then
             ns% = CInt(Res(i%)) '::: Номер строки
      
             '::: Ищем строку с заданным номером
      
             k% = 0
             p& = 1
             
             Do
             
                pb& = InStr(p&, Buf$, "<t>")
                If pb& = 0 Then Exit Do
                pe& = InStr(pb&, Buf$, "</t>")
             
                '::: Нашли - заносим текст
             
                If k% = ns% Then
                   vs$ = Mid$(Buf$, pb& + 3, pe& - pb& - 3)
                   Res(i%) = vs$
                   Exit Do
                End If
                k% = k% + 1
                p& = pe& + 1
             Loop
          End If
      Next i%
   End If
 
   '::: Удаляем рабочую директорию
 
   If objFSO.FolderExists(tmpDir$) Then
      Set tmp = objFSO.getFolder(tmpDir$)
      tmp.Delete
   End If
   getValues = Res
End Function
 
Sub UnZipFile(strArchive, strDest)
    Set objApp = CreateObject("Shell.Application")
    Set objArchive = objApp.Namespace(strArchive).Items()
    Set objDest = objApp.Namespace(strDest)
    objDest.CopyHere objArchive
End Sub
 
Sub Test()
    HomeDir$ = ThisWorkbook.Path
    Z = getValues(HomeDir$ + "\test.xlsx", "Sheet1", "B2,C3,D4,E5,F6,G7")
    For i% = 0 To UBound(Z)
        Debug.Print Z(i%)
    Next i%
End Sub