Sub Январь_Скругленныйпрямоугольник1_Щелчок()
Dim y1 As Long, y As Long, x, Filename, fso As Object, a$()
  On Error Resume Next

  ' задаём стартовую папку
  ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path

  ' вывод диалогового окна для запроса имени сохраняемого файла
  Filename = Application.GetOpenFilename("Text files (*.met),", , "Открыть файл для обработки", "Load data", True)

  ' если пользователь отказался от выбора  файла - отменяем загрузку данных
  If VarType(Filename) = vbBoolean Then Exit Sub

  Set fso = CreateObject("Scripting.FileSystemObject")
  With Worksheets("Январь")
    y = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not IsEmpty(.Cells(y, 1)) Then y = y + 1
    y1 = y
    For Each x In Filename
      a = Split(fso.OpenTextFile(x).ReadAll, vbNewLine)
      .Cells(y, 2).Resize(8).Value = WorksheetFunction.Transpose( _
          Array(a(180), a(360), a(540), a(720), a(900), a(1080), a(1260), a(1440)))
      .Cells(y, 1).Resize(8).Value = CDate(a(0))
      y = y + 8
    Next
    With .Range("B" & y1 & ":B" & y)
      .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 9), Array(2, 1), Array(3, 2), Array(4, 2), Array(5, 1), Array(6, 2), _
        Array(7, 2), Array(8, 2), Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 1), Array(13, 1 _
        ), Array(14, 1)), TrailingMinusNumbers:=True
      .Copy
      .Offset(, -1).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
      .Delete xlShiftToLeft
    End With
    With .Range("B" & y1 & ":J" & y)
      .NumberFormat = "General"
      .Replace What:=".", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With
  End With
End Sub