Attribute VB_Name = "macroMSfill"
'''
' типы
'
' описание данных
'
Type TData
' лист
  l As String
' строка
  s As String
' столбец
  c As String
' значение
  v As String
' номер формата
  f As String
End Type
Type TFormat
  n As String
' тип - формат
  t As String
' wrap
  w As String
' горизонтальное выравнивание
  hv As String
' вертикальное выравнивание
  vv As String
' обрамление
  r As String
' font name
  fn As String
' font size
  fs As String
End Type
'''
' процедуры и функции
'
'Function fillTable(inFile As String, oBook As Workbook) As String
Function fillTable(inFile As String) As String

  Dim oBook As Workbook
  Dim nFileNum As Integer
  Dim i As Integer, j As Integer, n As Integer, k As Integer, m As Integer, kk As Integer
  Dim cStroka As String, aStroki() As String, lWrap As Boolean, lFrm As Boolean
  Dim a() As String, x As String, y As String
  Dim iSh, oSh, fs, ooSh, oRn
  Dim aD As TData, aF() As TFormat
  Dim ef As TFormat
  ReDim aF(0)
  '
  ' отлавливаем ошибки
  '
  On Error GoTo ErrorHandler

  Set oBook = ActiveWorkbook 

  Application.DecimalSeparator = "."
  Application.UseSystemSeparators = False

  Set fs = CreateObject("Scripting.FileSystemObject")
  lWrap = False
  lFrm = False
  If fs.FileExists(inFile) Then
    nFileNum = FreeFile
    Open inFile For Input As nFileNum
    cStroka = ""
    '
    ' загружаем форматы из файла
    '
    Do While Not EOF(nFileNum)
      Line Input #nFileNum, cStroka
      If Not (Trim(cStroka) = "") Then
        a = Split(cStroka, "^")
        ReDim Preserve a(9)
        If UCase(a(0)) = "F" Then
          kk = UBound(aF) + 1
          ReDim Preserve aF(kk)
          ef.n = a(1)
          ef.t = a(2)
          ef.w = a(3)
          ef.hv = a(4)
          ef.vv = a(5)
          ef.r = a(6)
          ef.fn = a(7)
          ef.fs = a(8)
          aF(kk) = ef
        End If
      End If
    Loop
    '
    ' загружаем из файла данные
    '
    Seek #nFileNum, 1
    cStroka = ""
    On Error Resume Next
    Do While Not EOF(nFileNum)
      cStroka = ""
      Line Input #nFileNum, cStroka
      If Err <> 0 Then
        GoTo OpNext
      End If
      If Not (Trim(cStroka) = "") Then
        a = Split(cStroka, "^")
        ReDim Preserve a(9)
        If UCase(a(0)) = "D" Then
          aD.l = a(1)
          aD.s = a(2)
          aD.c = a(3)
          aD.v = a(4)
          aD.f = a(5)
        '
        ' заполнение документа
        '
        Set oSh = oBook.Worksheets(aD.l)
        If Err <> 0 Then
          Resume OpNext
        End If
        j = InStr(1, aD.c, ":", vbTextCompare)
        If j > 0 Then
          x = Trim(Left(aD.c, j - 1))
          y = Trim(Mid(aD.c, j + 1))
          Set oRn = oSh.Range(oSh.Cells(Val(aD.s), IIf(IsNumeric(x), Val(x), l)), oSh.Cells(Val(aD.s), IIf(IsNumeric(y), Val(y), y)))
          If Err <> 0 Then
            Resume OpNext
          End If
          oRn.Merge (True)
        Else
          Set oRn = oSh.Cells(Val(aD.s), IIf(IsNumeric(aD.c), Val(aD.c), aD.c))
          If Err <> 0 Then
            Resume OpNext
          End If
        End If
        With oRn
          ' задан формат ?
          If aD.f <> "" Then
            ' формат задан
            For j = 1 To UBound(aF)
              If aD.f = aF(j).n Then
                k = j
                Exit For
              End If
            Next
            ' формат найден
            If k > 0 Then
            
              Select Case UCase(aF(k).t)
              Case "V"
                .NumberFormat = "0.00"
              Case "T"
                .NumberFormat = "@"
              Case "F"
                .Formula = aD.v
                lFrm = True
              Case "FV"
                .NumberFormat = "0.00"
                .Formula = aD.v
                lFrm = True
              Case "FT"
                .NumberFormat = "@"
                .Formula = aD.v
                lFrm = True
              End Select
       
              Select Case UCase(aF(k).w)
              Case "W"
                .WrapText = True
                lWrap = True
              Case "U"
                .WrapText = False
              End Select
     
              Select Case UCase(aF(k).hv)
              Case "C"
                .HorizontalAlignment = xlHAlignCenter
              Case "L"
                .HorizontalAlignment = xlHAlignLeft
              Case "R"
                .HorizontalAlignment = xlHAlignRight
              End Select
     
              Select Case UCase(aF(k).vv)
              Case "C"
                .VerticalAlignment = xlVAlignCenter
              Case "T"
                .VerticalAlignment = xlVAlignTop
              Case "B"
                .VerticalAlignment = xlVAlignBottom
              End Select
                
              If aF(k).r <> "" Then
                j = InStr(1, aF(k).r, ";", vbTextCompare)
                If j > 0 Then
                  x = Trim(Mid(aF(k).r, j + 1))
                  n = Val(Trim(Left(aF(k).r, j - 1)))
                  If n > 0 Then
                    If n <= 25 Then
                      n = xlHairline
                    ElseIf n <= 50 Then
                      n = xlThin
                    ElseIf n <= 75 Then
                      n = xlMedium
                    Else
                      n = xlThick
                    End If
                  Else
                    n = xlNone
                  End If
                Else
                  x = Trim(aF(k).r)
                  n = xlHairline
                End If
                Do While Len(x) > 0
                  Select Case UCase(Left(x, 1))
                  Case "A"
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).Weight = n
                    .Borders(xlEdgeTop).ColorIndex = xlAutomatic
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).Weight = n
                    .Borders(xlEdgeRight).ColorIndex = xlAutomatic
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).Weight = n
                    .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeLeft).Weight = n
                    .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
                    Exit Do
                  Case "T"
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).Weight = n
                    .Borders(xlEdgeTop).ColorIndex = xlAutomatic
                  Case "R"
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).Weight = n
                    .Borders(xlEdgeRight).ColorIndex = xlAutomatic
                  Case "B"
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).Weight = n
                    .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
                  Case "L"
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeLeft).Weight = n
                    .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
                  End Select
                  x = Mid(x, 2)
                Loop
              End If
       
              If aF(k).fn <> "" Then
                .Font.name = aF(k).fn
              End If
     
              If aF(k).fs <> "" Then
                .Font.Size = aF(k).fs
              End If
         
            End If
          End If
          ' заносим значение
          .Value = aD.v
        End With
        End If
      End If
OpNext:      
      Err.Clear
    Loop
    Close nFileNum
  End If
  On Error GoTo ErrorHandler 
  If lWrap Then
    ' выравнивание строк по высоте, если есть wrap
    For Each oSh In oBook.Worksheets
      oSh.Rows.AutoFit
    Next
'  Else
'    If UBound(aF) > 0 Then
'      ' выравнивание колонок по ширине (может сломать формат)
'      For Each oSh In oBook.Worksheets
'        oSh.Columns.AutoFit
'      Next
'    End If
  End If
  If lFrm Then
'    For Each oSh In oBook.Worksheets
'      oSh.Calculate
'    Next
    Application.Calculation = xlCalculationAutomatic
  End If
  fillTable = ""
  Exit Function
'
' обрабатываем ошибки
'
ErrorHandler:
' возвращается информация об ошибке: номер ; описание ; имя процедуры
  fillTable = str(Err.Number) + ";" + Err.Description + ";" + Err.Source
  Err.Clear
  Exit Function

End Function
