Sub DDDD200()
Dim iWb As Workbook, cl As Range, iAdrs$, iOf&, lClmn&, lRow&, r1&, r2&, arr(), t
t = Timer   'таймер, строку можно удалить
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("данные").Cells.Clear
Set iWb = Workbooks.Open(Filename:="C:\test\" & Worksheets("Лист6").Range("K15").Value)
With iWb.Worksheets(1)
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lClmn = .Cells(3, .Columns.Count).End(xlToLeft).Column
    Set cl = .Columns(1).Find("DATE", After:=.Cells(lRow, 1))
    If Not cl Is Nothing Then
        iAdrs = cl.Address
        Do
            r1 = cl.Offset(1).Row
            Set cl = .Columns(1).FindNext(cl)
            If cl.Address <> iAdrs Then
                r2 = cl.Offset(-1).Row
            Else
                r2 = lRow
            End If
            arr = .Range(.Cells(r1, 1), .Cells(r2, lClmn)).Value
            'для вставки данных начиная с ячейки 'A1' заменить в строке ниже 'A2' на 'A1'
            ThisWorkbook.Worksheets("данные").Range("A2").Offset(, iOf).Resize(UBound(arr), UBound(arr, 2)) = arr
            iOf = iOf + 12
            Erase arr
        Loop While Not cl Is Nothing And cl.Address <> iAdrs
    End If
End With
iWb.Close False
Application.ScreenUpdating = True
MsgBox "Готово!" & vbCrLf & Round(Timer - t, 3) & " сек." 'сообщение, строку можно удалить
End Sub