Sub Сбор_Данных()
Set shSh = Sheets("Справочник листов")
Set shOUT = Sheets("Результат")
lrSh = shSh.Cells(Rows.Count, 1).End(xlUp).Row
shArr = Range("A1:A" & lrSh)
Set dic = CreateObject("Scripting.Dictionary")
For ssh = 1 To lrSh
Set sh = Sheets(shSh.Cells(ssh, 1).Value)
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lr
    If sh.Cells(i, "D").Value = "" Then
    ii = i
    Else
    k = k + 1
    gg = sh.Range("B" & ii).Value
    arr = Array(sh.Name, sh.[A1].Value, sh.Range("A" & i).Value, sh.Range("B" & ii).Value, _
                sh.Range("D" & i).Value, sh.Range("B" & i).Value, sh.Range("C" & i).Value, _
                sh.Range("E" & i).Value, sh.Range("F" & i).Value, sh.Range("G" & i).Value)
    dic.Item(k) = arr
    End If
    Next
Next
lr = shOUT.UsedRange.Rows.Count
arr = Application.Transpose(Application.Transpose(dic.items))
shOUT.Range("A" & UBound(arr) + 3, "J" & lr).Clear
shOUT.Range("A3").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub