Файл: RepToExcel.vbs 

' Собрал: Орлов В.И.
' цшдшфьы"нфтвучюкг
' icq:5279603
' Изменен:02.04.2012

Option Explicit

Dim flag, ext, MyDir, FSO, Files, strFiles, ExcelFile, File, strFile, arrFiles, objExcel, objWorkBook
Dim titAdd, lists, ExistLists, i, NoExistLists, ThisList
ext         = "log"  'расширение отчетфайлов
MyDir       = "\\domen\shara\Inventary"   ' Наша директория
Set FSO     = CreateObject("Scripting.FileSystemObject")
Set Files   = FSO.GetFolder(MyDir).Files  ' Список файлов в нашей директории
strFiles    = ""  ' Список фалов без разширением в строковом виде
ExcelFile   = MyDir & "\" & "inventary.xlsx"   ' Наш эксель файл
Dim arrTitle(15)  ' Поля сводной таблицы "ИТОГИ"
 arrTitle(0) = trim("Дата инвентаризации         ")
 arrTitle(1) = trim("Компьютер                   ")
 arrTitle(2) = trim("Описание ПК                 ")
 arrTitle(3) = trim("Модель компа                ")
 arrTitle(4) = trim("Процессор                   ")
 arrTitle(5) = trim("Производитель корпуса       ")
 arrTitle(6) = trim("Серийник с корпуса          ")
 arrTitle(7) = trim("Серийник из биос            ")
 arrTitle(8) = trim("Общий размер памяти в байтах")
 arrTitle(9) = trim("Операционка                 ")
 arrTitle(10) = trim("Организация ПК             ")
 arrTitle(11) = trim("Организация пользователя   ")
 arrTitle(12) = trim("SerialNumber               ")
 arrTitle(13) = trim("наименование CD-ROM        ")
 arrTitle(14) = trim("Производитель биос         ")
 arrTitle(15) = trim("Ключ Windows               ")
                
For Each File In Files
   if right(File.Name, len(ext)) = ext then
      strFiles = strFiles & File.Name & vbNewLine
   end if
Next
arrFiles = split(strFiles, "." & ext & vbNewLine) ' Список фалов без разширения в массиве

'   On Error resume next 
   Set objExcel = CreateObject("Excel.Application")  ' объект эксель
   objExcel.Application.DisplayAlerts = False
   objExcel.Visible = True  ' Отобразить эксель

   if FSO.FileExists(ExcelFile) then
      ' Открываем эксель файл
      objExcel.Workbooks.Open (ExcelFile)  ' Открываем наш файл эксель
   else
      ' Создаем эксель файл
         objExcel.SheetsInNewWorkbook = 1 ' один пока лист при создании
         Set objWorkbook = objExcel.Workbooks.Add() ' Создали книгу
         objWorkbook.Sheets(1).name = "ИТОГИ"
         objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A1").Formula = "=COUNTA(A2:A30000)" ' Поставили счетчик добавленных компов
         for titadd=0 to ubound(arrTitle) ' добавляем заголовки сводной таблицы
            objExcel.ActiveWorkbook.Sheets("ИТОГИ").cells(1,titadd+2).value = arrTitle(titadd)
         next
    objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("B2").Select
    With objExcel.ActiveWindow  ' Зкрепляем азголовок таблицы
        .SplitColumn = 1
        .SplitRow = 1
        .FreezePanes = True
    End With
         'objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A:A").ColumnWidth = 0  ' Прячем первый столбец
         objExcel.ActiveWorkbook.SaveAs ExcelFile ' Сохранили с нашим именем в нашем месте
   end if

lists       = objExcel.ActiveWorkbook.Sheets.count ' Количество листов
ExistLists  = "СпискЛистов "
for i = 1 to lists
      ExistLists =  ExistLists & " " & objExcel.ActiveWorkbook.Sheets(i).name
next

NoExistLists = ""
for i = 0 to ubound(arrFiles) ' Собираем список файлов отсутствующих в книге
   if instr(lcase(ExistLists), lcase(arrFiles(i))) < 1 then
      NoExistLists = NoExistLists & arrFiles(i) & vbNewLine
   end if
next

  NoExistLists = split(NoExistLists, vbNewLine)
   for i = 0 to ubound(NoExistLists)-1 ' Добавляем недостающие листы и инфу в них
      Set ThisList = objExcel.ActiveWorkbook.Sheets.Add
      ThisList.Name = NoExistLists(i)
'------------------------------ ГИПЕРССЫЛКИ -----------------------------------
   ' add 
   ' Ячейка куда вставить гипессылку, _
   ' Файл из которого открыть, _
   ' TextToDisplay, _
   ' Подсказка
      objExcel.ActiveWorkbook.Sheets("ИТОГИ").Hyperlinks.Add _
         objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A" & objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A1").value+2), _
         "", _  
         "'" & NoExistLists(i) & "'" & "!A1", _
         NoExistLists(i)
         objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A" & objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A1").value+1).Hyperlinks(1).TextToDisplay = NoExistLists(i)
      objExcel.ActiveWorkbook.Sheets(NoExistLists(i)).Hyperlinks.Add _
         objExcel.ActiveWorkbook.Sheets(NoExistLists(i)).Range("A1"), _
         "", _  
         "'ИТОГИ'" & "!A1", _
         "Дата инвентаризации"
         objExcel.ActiveWorkbook.Sheets(NoExistLists(i)).Range("A1").Hyperlinks(1).TextToDisplay = "Дата инвентаризации"
'------------------------------ ГИПЕРССЫЛКИ -----------------------------------
      AddInfo(ThisList)
   next

   if NOT objExcel.ActiveWorkbook.Sheets(1).name = "ИТОГИ" then ' Если первый лист не ИТОГИ
      objExcel.ActiveWorkbook.Sheets("ИТОГИ").Move , objExcel.ActiveWorkbook.Sheets(1) ' Делаем ИТОГИ первым листом
      objExcel.ActiveWorkbook.Sheets(1).Move , objExcel.ActiveWorkbook.Sheets(2)
   end if
   objExcel.ActiveWorkbook.Sheets("ИТОГИ").select ' Выбираем лист ИТОГИ и добавляем формулу
   objExcel.Range("B2:Q" & objExcel.ActiveWorkbook.Sheets("ИТОГИ").Range("A1").value+1).Formula = "=IF(INDIRECT(CONCATENATE(""$A$"",ROW()))<>"""",INDIRECT(CONCATENATE(""'"",INDIRECT(CONCATENATE(""$A$"",ROW())),""'!B"",COLUMN()-1)),"""")"

   WScript.CreateObject("WScript.Shell").popup "Завершили сбор инфы из логов !", 5, "КАНЕС.", vbInformation
   objExcel.ActiveWorkbook.Save
'   objExcel.ActiveWorkbook.close
'   objExcel.Quit
   objExcel.Application.DisplayAlerts = True
   set objExcel = nothing

function AddInfo(list)
   dim file, ContentFile, ncell, iarrt
   file = MyDir & "\" & list.Name & ".log"
   ContentFile = split(CreateObject("Scripting.FileSystemObject").OpenTextFile(file, 1).ReadAll, vbNewLine)
       With list
         for ncell=0 to ubound(ContentFile)
            for iarrt = 0 to ubound(arrTitle)
               insertTo iarrt+1,  arrTitle(iarrt), ContentFile(ncell), list
            next
               if inStr(ContentFile(ncell), " -#- ") > 0 then
                  .cells(ncell+1+16,1).value = split(ContentFile(ncell), " -#- ")(1)
                  .cells(ncell+1+16,2).value = split(ContentFile(ncell), " -#- ")(0)
               else
                  .cells(ncell+1+16,1).value = ContentFile(ncell)
               end if
         next
       End With
end function

function insertTo(num,strFnd,Contnt, list)
   if instr(Contnt, trim(strFnd)) > 0 and inStr(Contnt, " -#- ") > 0 then
         list.cells(num,1).value = trim(strFnd)
         list.cells(num,2).value = trim(split(Contnt, " -#- ")(0))
   end if
end function