Вывод строк и ячеек из множества файлов

[iipokypop]

Здравствуйте!
Суть проблемы и мольба о помощи:
-есть нное кол-во однотипных файлов,нужно сделать сбор данных в одном файле

Нашел в интернете макрос по сбору ячеек из файлов,переделал (не работат на 2003,на 2010 работает).
В приложенном примере в папке дата,строки выделенные желтым надо тоже прикрутить к финальной сводке.
То есть идет фамилия,далее данные по ячейкам,а вот ниже должны идти строки(желтым помечено).
После указанных выше строк,идет следующая фамилия и т.д.

В макросах не особо силен(честно говоря увидел это дело на практике не далее чем три дня назад),поэтому требуется помощь истинных гуру.
Пароль на макрос - 111

[andrewkard]

Добрый день.
Что то типа этого:

Код Выделить Развернуть


Sub FileList()
    Dim oFS As Object, oFl As Object
    Dim oWb As Workbook
    Dim sFolder As String
    Dim sFlNm$, sFlDate$, sFIO$, sINN$, sOkato$
    Dim lRw&: lRw = 5

    sFolder = ThisWorkbook.Worksheets("Список файлов").Cells(1, 3)
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set oFS = oFS.getfolder(sFolder)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each oFl In oFS.Files
        Set oWb = Workbooks.Open(oFl)
        sFlNm = oFl.Name
        sFlDate = oFl.DateCreated
        sFIO = oWb.Worksheets(1).[J8].Value
        sINN = oWb.Worksheets(1).[C8].Value
        sOkato = oWb.Worksheets(1).[D6].Value
        oWb.Close
        Set oWb = Nothing
       
        With ThisWorkbook.Worksheets("Список файлов")
        .Cells(lRw, 2) = sFlNm
        .Cells(lRw, 3) = sFlDate
        .Cells(lRw, 4) = sFIO
        .Cells(lRw, 5) = sINN
        .Cells(lRw, 6) = sOkato
        End With
        lRw = lRw + 1
    Next
    Set oFS = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub