For i = Application.WorksheetFunction.CountA(Columns(1)) To 2 Step -1
 If (Len(Cells(i, 3)) > 0) Then
   Call drawDown(i, Cells(i, 3))
 End If
Next i

Sub drawDown(startRow As Integer, counter As Integer)
Dim i As Integer
Dim curCell As Range

i = 1
Do
    Set curCell = Cells(startRow, 4).Offset(i, 0)
    If Len(curCell) = 0 Then
        curCell = Cells(startRow, 1)
        counter = counter - 1
    End If
    i = i + 1
Loop While counter > 0
End Sub

Option Explicit
Const RowStart = 3
Const ColStart = 2

Dim objFSO As Object, objFolder As Object, objFile As Object

Sub workfile(filePath As String)
Dim wtemp As Worksheet
Dim wdb As Worksheet
Dim marsh As String
Dim tempstring As String, tempotdel As String, tempoper As String, tempcaption As String
Dim i As Integer
Dim startCell As Range

    Application.ScreenUpdating = False

    Set wtemp = Worksheets("Temp")
    Set wdb = Worksheets("БД")

    Worksheets("Temp").Cells.Clear
    
    On Error Resume Next

        loadfile (filePath)
        
        Set startCell = Worksheets("Temp").Cells.Find(What:="ЯкорьМакроса", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
        
        If InStr(startCell.Offset(0, 1), "(") <> 0 Then
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(Left(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(") - 1)) & ";" & myTrim(Mid(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(")))
        Else
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(startCell.Offset(0, 1))
        End If
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 2) = myTrim(startCell.Offset(1, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 3) = myTrim(startCell.Offset(2, 1))
        If InStr(startCell.Offset(3, 1), "+") Then
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(Left(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+") - 1)) & ";" & myTrim(Mid(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+")))
        Else
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(startCell.Offset(3, 1))
        End If
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 5) = myTrim(startCell.Offset(4, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 6) = myTrim(startCell.Offset(5, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 7) = myTrim(startCell.Offset(6, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 8) = myTrim(startCell.Offset(7, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 10) = filePath
        
        marsh = ""
        tempstring = ""
        tempotdel = ""
        tempoper = ""
        tempcaption = ""
        
        Set startCell = Worksheets("Temp").Cells.Find(What:="Якорь2", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Offset(-2, 0)
        
        For i = 3 To 303
            If (startCell.Offset(i, 0) = "Ошибка") Then
                Exit For
            End If
            If (startCell.Offset(i, 1)) <> "" Then
                If tempoper <> "" Then
                    tempstring = tempotdel & "$" & tempoper & "$" & tempcaption & "@"
                    marsh = marsh & tempstring
                End If
                tempstring = ""
                tempotdel = myTrim(startCell.Offset(i, 0))
                tempoper = Format(CInt(startCell.Offset(i, 1)), "000")
                tempcaption = myTrim(startCell.Offset(i, 2))
            Else
                If (startCell.Offset(i, 0) <> "") Then
                    tempotdel = tempotdel & ";" & myTrim(startCell.Offset(i, 0))
                End If
                If (startCell.Offset(i, 2) <> "") Then
                    tempcaption = tempcaption & " " & myTrim(startCell.Offset(i, 2))
                End If
            End If
        Next i
        marsh = marsh & tempotdel & "$" & tempoper & "$" & tempcaption & "@"
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 9) = marsh
        wdb.Cells(RowStart + Range("TPCount"), ColStart) = Range("TPCount") + 1

    
    wdb.Activate
    
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    
End Sub

Sub loadfile(filePath As String)
Dim RngCopy
Dim oWordApl As Object
Dim oDocument As Object

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next

    Set oWordApl = CreateObject("word.application")
    Set oDocument = oWordApl.Documents.Open(filePath)
    oWordApl.Visible = True
    
     With oWordApl.ActiveDocument
        Set RngCopy = .Range(0, .Characters.Count)
        RngCopy.Select
        oWordApl.Selection.Copy
    End With

    With Worksheets("Temp")
        .Select
        .Range("A1").Select
        .Paste
    End With
    
    oWordApl.ActiveDocument.Close
    oWordApl.Visible = False
    oWordApl.Quit
    Set RngCopy = Nothing
    Set oDocument = Nothing
    Set oWordApl = Nothing
    
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub Get_All_File_from_SubFolders()
Dim sFolder As String

    sFolder = chooseFolder
    
    If sFolder <> "" Then
    
         sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    
            Application.ScreenUpdating = False
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            GetSubFolders sFolder
            Set objFolder = Nothing
            Set objFSO = Nothing
            Application.ScreenUpdating = True
    
    End If
      
End Sub

Private Sub GetSubFolders(sPath)
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        workfile (objFile.path)
        ThisWorkbook.Save
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.path & Application.PathSeparator
    Next
End Sub

Function chooseFolder()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim path As String
 
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
 With fd
    .ButtonName = "Выбрать"
    If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
            path = vrtSelectedItem
        Next vrtSelectedItem
    Else
        Exit Function
    End If
 End With
 Set fd = Nothing
 
 If path <> "" Then
    chooseFolder = path
 Else
    chooseFolder = ""
 End If
End Function

Function myTrim(text As String) As String
  text = Trim(text)
    Do While InStr(text, "  ")
      text = Replace(text, "  ", " ")
    Loop
  myTrim = text
End Function

Sub aloneFile()
Dim filePath As String

    filePath = Application.GetOpenFilename
    If filePath <> "" Then
        workfile (filePath)
    End If
End Sub

Application.ScreenUpdating = False 
For i = 1 To TeamQuant - 1
        Call AddRow
        Application.ScreenUpdating = False
    Next i

'----------------------
Sub AddRow() 'Добавление пустой строки
Dim LastRow As Range
    
    Application.ScreenUpdating = False
    Call UpdateVar
    Application.ScreenUpdating = False
    Set LastRow = Range("Cellar").Offset(-1, 0).Resize(1, FieldLeft + (QuestQuant + 3) * RoundQuant + 3) 'Выделяем последнюю строку таблицы
    With LastRow
        .Copy
        .Offset(1, 0).Insert Shift:=xlDown
        .Offset(0, 0).Borders(xlEdgeBottom).Weight = xlThin
        .Offset(1, 0).Resize(1, 4).ClearContents 'Очищаем значение только что вставленной строки
    End With
End Sub