Упарился я его переделывать
мож
кому пригодиться
Option Compare Database
Option Explicit
Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Sub btnProcess_Click()
On Error GoTo Error_
Dim fl1 As Integer, ErrCount As Integer
Me.Dirty = False
If Nz(Me!path_xml, "") = "" Then
MsgBox "Сначала надо выбрать путь куда сохранять"
Exit Sub
End If
If Nz(Me!КодСтраховойОрганизации, 0) = 0 Then
MsgBox "Сначала надо выбрать страховую компанию"
Exit Sub
End If
If Nz(Me!КодВидаСтрахования, 0) = 0 Then
MsgBox "Сначала надо выбрать вид страхования"
Exit Sub
End If
mdTools.SaveBaseXml Me!path_xml
'Начинаем
Dim wa As Object 'Object 'Excel.Application
Dim wd As Object 'Object 'Excel.Workbook
Dim ws As Object 'Object 'Excel.Worksheet
Dim c1 As Object 'Object 'Excel.Cell
Dim ts1 As Object
Dim fs As New fso
Dim first_row As Long, last_row As Long, tmp_int As Integer, tmp_dbl As Double, tmp_str As String
Dim ii As Integer, jj As Integer, kk As Integer, curdog As String, cursub As String, curreg As String, prevdog As String, prevsub As String, prevreg As String
Dim curdog8 As String, cursub8 As String, curreg8 As String, prevdog8 As String, prevsub8 As String, prevreg8 As String
Dim payments_all As Double, payments_gov As Double
Dim ListName As String, ListNumber As Integer, tmpCellName As String
Set wa = CreateObject("Excel.Application")
Set wd = wa.WorkBooks.Open(Me!path_xls)
'Выбор листа
If wd.Sheets.Count > 1 Then
Set wd_ = wd
DoCmd.OpenForm "frmList1", , , , , acDialog, Me.Name
If IsLoaded("frmList1") Then
If Nz(Forms("frmList1")!lst1, 0) = 0 Then
DoCmd.Close acForm, "frmList1"
Set wd_ = Nothing
GoTo Exit_
Else
ListName = Forms("frmList1")!lst1.Column(1)
wd.Sheets(ListName).Select
DoCmd.Close acForm, "frmList1"
Set wd_ = Nothing
End If
End If
Else
ListName = wd.Sheets(1).Name
End If
ListNumber = wd.Sheets(ListName).Index
'Определение размеров
wa.Cells(1, 1).Select
wa.Range(wa.Selection, wa.ActiveCell.SpecialCells(xlLastCell)).Select
last_row = wa.ActiveCell.SpecialCells(xlLastCell).row
wa.Columns("A:A").Select
wa.Selection.Find(What:="1", After:=wa.ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
first_row = wa.ActiveCell.row
wa.Rows(first_row & ":" & first_row).Select
wa.Selection.Delete Shift:=xlUp
'Go
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from TempДоговорыДтСлучаи"
DoCmd.RunSQL "alter table TempДоговорыДтСлучаи alter column Код counter(1,1)"
DoCmd.RunSQL "delete * from TempДоговорыДт"
DoCmd.RunSQL "alter table TempДоговорыДт alter column Код counter(1,1)"
Dim rst As DAO.Recordset, rst2 As DAO.Recordset, КодДоговора As String, f As Field
Dim rstEv As DAO.Recordset
Dim flEdit As Boolean
DoCmd.OpenForm "frmProcess", acNormal
Forms!frmProcess.Caption = "Запись во временную талицу"
Forms!frmProcess.Repaint
Forms!frmProcess!ProgressBar.Max = last_row - first_row
Set ts1 = fs.fso.OpenTextFile(Me!path_xml, 8, 0, -2) '8=ForAppending, -1=Юникод
For ii = first_row To last_row
Forms!frmProcess!ProgressBar.Value = ii - first_row
Forms!frmProcess.Repaint
If Len(wa.Cells(ii, 1)) = 0 Then Exit For
If Asc(Left(wa.Cells(ii, 1), 1)) < 48 Or Asc(Left(wa.Cells(ii, 1), 1)) > 57 Then Exit For
Set rst = CurrentDb.OpenRecordset("select * from TempДоговорыДт")
КодДоговора = Nz(DLookup("Код", "TempДоговорыДт", "number = """ & wa.Cells(ii, mdTags.GetPos("number")) & _
""" and region = """ & wa.Cells(ii, mdTags.GetPos("region")) & _
""" and subject_name = """ & wa.Cells(ii, mdTags.GetPos("subject_name")) & """"), 0)
If КодДоговора = 0 Then
flEdit = False
rst.AddNew
КодДоговора = rst!Код
Else
flEdit = True
rst.MoveFirst
' rst.FindFirst
rst.Filter = "Код = " & КодДоговора
Set rst2 = rst.OpenRecordset
'If rst!number <> wa.Cells(ii, mdTags.GetPos("number")) Then Stop
rst2.Edit
End If
If flEdit Then
For Each f In rst2.Fields
If f.Name = "insurance_amount" Or f.Name = "insurance_premium" Or f.Name = "payments_all" Or f.Name = "payments_gov" Then
f.Value = f.Value + IIf(wa.Cells(ii, mdTags.GetPos(f.Name)) = "", 0, wa.Cells(ii, mdTags.GetPos(f.Name)))
End If
Next
rst2.Update
Else
For Each f In rst.Fields
If f.Name <> "Код" Then
tmp_str = Trim(wa.Cells(ii, mdTags.GetPos(f.Name)))
If f.Type = 8 And tmp_str <> "" Then
f.Value = wa.Cells(ii, mdTags.GetPos(f.Name))
GoTo Next1
End If
f.Value = IIf(tmp_str = "", Null, tmp_str)
Next1:
End If
Next
rst.Update
End If
If Len(wa.Cells(ii, mdTags.GetPos("event_description"))) > 0 Then
Set rstEv = CurrentDb.OpenRecordset("select * from TempДоговорыДтСлучаи where " & _
"КодДоговора = " & КодДоговора & _
" and event_description = """ & wa.Cells(ii, mdTags.GetPos("event_description")) & """")
If rstEv.RecordCount > 0 Then
rstEv.MoveFirst
rstEv.Edit
Set f = rstEv.Fields("estimation_value")
f.Value = f.Value + IIf(wa.Cells(ii, mdTags.GetPos(f.Name)) = "", 0, wa.Cells(ii, mdTags.GetPos(f.Name)))
Set f = rstEv.Fields("payment_val")
f.Value = f.Value + IIf(wa.Cells(ii, mdTags.GetPos(f.Name)) = "", 0, wa.Cells(ii, mdTags.GetPos(f.Name)))
Else
rstEv.AddNew
rstEv!КодДоговора = КодДоговора
For jj = 2 To rstEv.Fields.Count - 1
tmp_str = Trim(wa.Cells(ii, mdTags.GetPos(rstEv.Fields(jj).Name)))
If rstEv.Fields(jj).Type = 8 And tmp_str <> "" Then
rstEv.Fields(jj).Value = wa.Cells(ii, mdTags.GetPos(rstEv.Fields(jj).Name))
GoTo Next2
End If
rstEv.Fields(jj).Value = IIf(tmp_str = "", Null, tmp_str)
Next2:
Next
End If
rstEv.Update
End If
Next ii
wd.Close False
Set wd = Nothing
Set wa = Nothing
Set rst = CurrentDb.OpenRecordset("SELECT * FROM TempДоговорыДтДляXML ORDER BY number, region, subject_name")
If rst.RecordCount > 0 Then
rst.MoveLast
rst.MoveFirst
End If
Forms!frmProcess.Caption = "Запись в файл"
Forms!frmProcess.Repaint
Forms!frmProcess!ProgressBar.Max = rst.RecordCount
ii = 0
While Not rst.EOF
ii = ii + 1
Forms!frmProcess!ProgressBar.Value = ii
Forms!frmProcess.Repaint
curdog = rst!number
cursub = rst!subject_name
curreg = rst!region
If prevdog <> rst!number Then
ts1.WriteLine Space(4 * 1) & ""
ts1.WriteLine Space(4 * 2) & "" & Me![КодСтраховойОрганизации].Column(2) & ""
ts1.WriteLine Space(4 * 2) & "" & rst!КодВидаСтрахования & ""
ts1.WriteLine Space(4 * 2) & "" & ToUTF8(rst!region) & ""
ts1.WriteLine Space(4 * 2) & "" & ToUTF8(rst!number) & ""
ts1.WriteLine Space(4 * 2) & "" & Format(rst!date_contract, "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 2) & "" & Format(rst!date_contract, "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 2) & "" & Format(rst!end_date, "yyyy-mm-dd") & ""
'Получаем суммарные данные
tmp_str = Round(DSum("payments_all", "TempДоговорыДт", "number = """ & rst!number & """"), 2)
ts1.WriteLine Space(4 * 2) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
tmp_str = Round(DSum("payments_gov", "TempДоговорыДт", "number = """ & rst!number & """"), 2)
ts1.WriteLine Space(4 * 2) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
End If
If Not (prevdog = rst!number And prevsub = rst!subject_name And prevreg = rst!region) Then
kk = 1
ts1.WriteLine Space(4 * 2) & ""
ts1.WriteLine Space(4 * 3) & "" & ToUTF8(rst!subject_name) & ""
ts1.WriteLine Space(4 * 3) & "0"
tmp_str = Round(DSum("insurance_amount", "TempДоговорыДт", "number = """ & rst!number & """" & _
" and region = """ & rst!region & """" & _
" and subject_name = """ & rst!subject_name & """" _
), 2) 'rst!insurance_amount
ts1.WriteLine Space(4 * 3) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
tmp_str = Round(DSum("insurance_premium", "TempДоговорыДт", "number = """ & rst!number & """" & _
" and region = """ & rst!region & """" & _
" and subject_name = """ & rst!subject_name & """" _
), 2) 'rst!insurance_premium, 2)
ts1.WriteLine Space(4 * 3) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
tmp_dbl = rst!franshiza
'If tmp_dbl > 30 Then tmp_dbl = 30
ts1.WriteLine Space(4 * 3) & "" & Replace(tmp_dbl, ",", ".") & ""
ts1.WriteLine Space(4 * 3) & "" & ToUTF8("Нет") & ""
Else
kk = kk + 1
End If
If kk = 1 Then ts1.WriteLine Space(4 * 3) & ""
Set rstEv = CurrentDb.OpenRecordset("select * from TempДоговорыДтСлучаи where " & _
"КодДоговора = " & rst!Код)
If rstEv.RecordCount > 0 Then 'Дата страхового случая не пустая
ts1.WriteLine Space(4 * 4) & "" & ToUTF8(rstEv!event_description) & ""
ts1.WriteLine Space(4 * 4) & "" & Format(rstEv!event_date, "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 4) & "0"
ts1.WriteLine Space(4 * 4) & ""
tmp_str = Round(Nz(rstEv!estimation_value, 0), 2)
ts1.WriteLine Space(4 * 5) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
ts1.WriteLine Space(4 * 5) & "" & Format(rstEv!payment_date, "yyyy-mm-dd") & ""
tmp_str = Round(Nz(rstEv!payment_val, 0), 2)
ts1.WriteLine Space(4 * 5) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
Else
If kk = 1 Then
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
End If
End If
If kk = 1 Then ts1.WriteLine Space(4 * 3) & ""
prevdog = curdog
prevreg = curreg
prevsub = cursub
rst.MoveNext
If rst.EOF Then
ts1.WriteLine Space(4 * 2) & ""
ts1.WriteLine Space(4 * 1) & ""
GoTo Wend_
End If
If Not (curdog = rst!number And cursub = rst!subject_name And curreg = rst!region) Then
ts1.WriteLine Space(4 * 2) & ""
End If
If curdog <> rst!number Then
ts1.WriteLine Space(4 * 1) & ""
End If
Wend_:
Wend
ts1.WriteLine ""
DoCmd.SetWarnings True
MsgBox "Готово"
Exit_:
DoCmd.Close acForm, "frmProcess"
If Not wd Is Nothing Then wd.Close False
Set wd = Nothing
Set wa = Nothing
Exit2_:
DoCmd.Hourglass False
Exit Sub
Error_:
ErrCount = ErrCount + 1
Select Case fl1
Case 1
MsgBox "Ошибка в строке " & ii + 1 & " и в колонке " & tmpCellName
Case 2
MsgBox "Ошибка в строке " & wa.ActiveCell.row & ". Выполнение прервано."
Case 3
MsgBox "Ошибка в строке " & wa.ActiveCell.row & ". Выполнение прервано."
Case 4
MsgBox "Ошибка в строке " & wa.ActiveCell.row & ". Выполнение прервано."
End Select
'Debug.Print Err.Source, Err.HelpContext
Call GetError(Err.number, Err.Description, Me.Name, "btnProcess_Click")
If ErrCount = 1 Then
Resume Exit_
Else
Resume Exit2_
End If
End Sub
Private Sub btnProcess_Click_Old()
On Error GoTo Error_
Dim fl1 As Integer, ErrCount As Integer
Me.Dirty = False
If Nz(Me!path_xml, "") = "" Then
MsgBox "Сначала надо выбрать путь куда сохранять"
Exit Sub
End If
If Nz(Me!КодСтраховойОрганизации, 0) = 0 Then
MsgBox "Сначала надо выбрать страховую компанию"
Exit Sub
End If
If Nz(Me!КодВидаСтрахования, 0) = 0 Then
MsgBox "Сначала надо выбрать вид страхования"
Exit Sub
End If
mdTools.SaveBaseXml Me!path_xml
'Начинаем
Dim wa As Object 'Object 'Excel.Application
Dim wd As Object 'Object 'Excel.Workbook
Dim ws As Object 'Object 'Excel.Worksheet
Dim c1 As Object 'Object 'Excel.Cell
Dim ts1 As Object
Dim fs As New fso
Dim first_row As Long, last_row As Long, tmp_int As Integer, tmp_dbl As Double, tmp_str As String
Dim ii As Integer, jj As Integer, curdog As String, cursub As String, curreg As String, prevdog As String, prevsub As String, prevreg As String
Dim curdog8 As String, cursub8 As String, curreg8 As String, prevdog8 As String, prevsub8 As String, prevreg8 As String
Dim payments_all As Double, payments_gov As Double
Dim ListName As String, ListNumber As Integer, tmpCellName As String
Set ts1 = fs.fso.OpenTextFile(Me!path_xml, 8, 0, -2) '8=ForAppending, -1=Юникод
Set wa = CreateObject("Excel.Application")
Set wd = wa.WorkBooks.Open(Me!path_xls)
'Выбор листа
If wd.Sheets.Count > 1 Then
Set wd_ = wd
DoCmd.OpenForm "frmList1", , , , , acDialog, Me.Name
If IsLoaded("frmList1") Then
If Nz(Forms("frmList1")!lst1, 0) = 0 Then
DoCmd.Close acForm, "frmList1"
Set wd_ = Nothing
GoTo Exit_
Else
ListName = Forms("frmList1")!lst1.Column(1)
wd.Sheets(ListName).Select
DoCmd.Close acForm, "frmList1"
Set wd_ = Nothing
End If
End If
Else
ListName = wd.Sheets(1).Name
End If
ListNumber = wd.Sheets(ListName).Index
'Определение размеров
wa.Cells(1, 1).Select
wa.Range(wa.Selection, wa.ActiveCell.SpecialCells(xlLastCell)).Select
last_row = wa.ActiveCell.SpecialCells(xlLastCell).row
wa.Columns("A:A").Select
wa.Selection.Find(What:="1", After:=wa.ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
first_row = wa.ActiveCell.row
wa.Rows(first_row & ":" & first_row).Select
wa.Selection.Delete Shift:=xlUp
'Создание сводных таблиц
wd.Sheets.Add After:=wd.Sheets(wd.Sheets.Count)
wd.Sheets(wd.Sheets.Count).Name = "Summary1"
wd.Sheets.Add After:=wd.Sheets(wd.Sheets.Count)
wd.Sheets(wd.Sheets.Count).Name = "Summary2"
wd.Sheets(ListNumber).Select
Set ws = wd.Sheets(ListNumber)
Set c1 = wa.ActiveCell
'1
wa.Sheets("Summary1").Select
wa.ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
ListName & "!R" & first_row - 1 & "C1:R" & last_row & "C16", Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:="Summary1!R2C2", TableName:="pvt1", _
DefaultVersion:=xlPivotTableVersion12
tmpCellName = c1.Offset(-1, 1)
mdTags.Update_tmpCellName "number", tmpCellName
With wa.ActiveSheet.PivotTables("pvt1").PivotFields( _
tmpCellName)
.Orientation = xlRowField
.Position = 1
End With
tmpCellName = c1.Offset(-1, mdTags.GetPos("payments_all") - 1)
mdTags.Update_tmpCellName "payments_all", tmpCellName
wa.ActiveSheet.PivotTables("pvt1").AddDataField wa.ActiveSheet.PivotTables _
("pvt1").PivotFields(tmpCellName), _
"Сумма по полю " & tmpCellName, xlSum
tmpCellName = c1.Offset(-1, GetPos("payments_gov") - 1)
mdTags.Update_tmpCellName "payments_gov", tmpCellName
wa.ActiveSheet.PivotTables("pvt1").AddDataField wa.ActiveSheet.PivotTables _
("pvt1").PivotFields(tmpCellName), _
"Сумма по полю " & tmpCellName, xlSum
wa.ActiveWorkbook.ShowPivotTableFieldList = False
wa.ActiveSheet.PivotTables("pvt1").RowAxisLayout xlTabularRow
'2
wa.Sheets("Summary2").Select
wa.ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
ListName & "!R" & first_row - 1 & "C1:R" & last_row & "C16", Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:="Summary2!R2C2", TableName:="pvt2", _
DefaultVersion:=xlPivotTableVersion12
tmpCellName = c1.Offset(-1, 1)
' mdTags.Update_tmpCellName "number", tmpCellName
With wa.ActiveSheet.PivotTables("pvt2").PivotFields( _
tmpCellName)
.Orientation = xlRowField
.Position = 1
End With
tmpCellName = c1.Offset(-1, mdTags.GetPos("region") - 1)
mdTags.Update_tmpCellName "region", tmpCellName
With wa.ActiveSheet.PivotTables("pvt2").PivotFields( _
tmpCellName)
.Orientation = xlRowField
.Position = 2
End With
tmpCellName = c1.Offset(-1, mdTags.GetPos("subject_name") - 1)
mdTags.Update_tmpCellName "subject_name", tmpCellName
With wa.ActiveSheet.PivotTables("pvt2").PivotFields( _
tmpCellName)
.Orientation = xlRowField
.Position = 3
End With
tmpCellName = c1.Offset(-1, mdTags.GetPos("insurance_amount") - 1)
mdTags.Update_tmpCellName "insurance_amount", tmpCellName
wa.ActiveSheet.PivotTables("pvt2").AddDataField wa.ActiveSheet.PivotTables _
("pvt2").PivotFields(tmpCellName), _
"Сумма по полю " & tmpCellName, xlSum
tmpCellName = c1.Offset(-1, GetPos("insurance_premium") - 1)
mdTags.Update_tmpCellName "insurance_premium", tmpCellName
wa.ActiveSheet.PivotTables("pvt2").AddDataField wa.ActiveSheet.PivotTables _
("pvt2").PivotFields(tmpCellName), _
"Сумма по полю " & tmpCellName, xlSum
wa.ActiveWorkbook.ShowPivotTableFieldList = False
wa.ActiveSheet.PivotTables("pvt2").RowAxisLayout xlTabularRow
wa.ActiveSheet.PivotTables("pvt2").PivotFields(Get_tmpCellName("number")). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
wa.ActiveSheet.PivotTables("pvt2").PivotFields(Get_tmpCellName("region")). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
wa.ActiveSheet.PivotTables("pvt2").PivotFields(Get_tmpCellName("subject_name")). _
Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
wd.Sheets(ListNumber).Select
DoCmd.OpenForm "frmProcess", acNormal
Forms!frmProcess.Repaint
Forms!frmProcess!ProgressBar.Max = last_row - first_row
For ii = first_row To last_row
Forms!frmProcess!ProgressBar.Value = ii - first_row
Forms!frmProcess.Repaint
If Len(wa.Cells(ii, 1)) = 0 Then Exit For
If Asc(Left(wa.Cells(ii, 1), 1)) < 48 Or Asc(Left(wa.Cells(ii, 1), 1)) > 57 Then Exit For
curdog = wa.Cells(ii, mdTags.GetPos("number"))
cursub = wa.Cells(ii, mdTags.GetPos("subject_name"))
curreg = wa.Cells(ii, mdTags.GetPos("region"))
curdog8 = ToUTF8(curdog)
cursub8 = ToUTF8(cursub)
curreg8 = ToUTF8(curreg)
If prevdog <> curdog Then
ts1.WriteLine Space(4 * 1) & ""
ts1.WriteLine Space(4 * 2) & "" & Me![КодСтраховойОрганизации].Column(2) & ""
ts1.WriteLine Space(4 * 2) & "" & Me!КодВидаСтрахования & ""
ts1.WriteLine Space(4 * 2) & "" & curreg8 & ""
ts1.WriteLine Space(4 * 2) & "" & curdog8 & ""
ts1.WriteLine Space(4 * 2) & "" & Format(wa.Cells(ii, mdTags.GetPos("date_contract")), "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 2) & "" & Format(wa.Cells(ii, mdTags.GetPos("begin_date")), "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 2) & "" & Format(wa.Cells(ii, mdTags.GetPos("end_date")), "yyyy-mm-dd") & ""
'Получаем суммарные данные
wa.Worksheets("Summary1").Activate
wa.Columns("B:B").Select
wa.Selection.Find(What:=curdog, After:=wa.ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
tmp_str = wa.Cells(wa.ActiveCell.row, 3)
ts1.WriteLine Space(4 * 2) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
tmp_str = wa.Cells(wa.ActiveCell.row, 4)
ts1.WriteLine Space(4 * 2) & "" & Replace(IIf(tmp_str = "", "0", tmp_str), ",", ".") & ""
wd.Sheets(1).Select
End If
If Not (prevdog = curdog And prevsub = cursub And prevreg = curreg) Then
ts1.WriteLine Space(4 * 2) & ""
ts1.WriteLine Space(4 * 3) & "" & cursub8 & ""
ts1.WriteLine Space(4 * 3) & "0"
'Получаем суммарные данные
wa.Worksheets("Summary2").Activate
wa.Columns("B:B").Select
wa.Selection.Find(What:=curdog, After:=wa.ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
wa.ActiveCell.Offset(0, 1).Select
While wa.ActiveCell <> curreg
wa.ActiveCell.Offset(1, 0).Select
Wend
wa.ActiveCell.Offset(0, 1).Select
While wa.ActiveCell <> cursub
wa.ActiveCell.Offset(1, 0).Select
Wend
ts1.WriteLine Space(4 * 3) & "" & Replace(wa.Cells(wa.ActiveCell.row, 5), ",", ".") & ""
ts1.WriteLine Space(4 * 3) & "" & Replace(wa.Cells(wa.ActiveCell.row, 6), ",", ".") & ""
wa.Worksheets(ListNumber).Activate
fl1 = 1
tmpCellName = "Франшиза"
tmp_str = Replace(wa.Cells(ii, mdTags.GetPos("franshiza")), ",", ".")
tmp_dbl = IIf(tmp_str = "", 0, Val(tmp_str))
fl1 = 0
If tmp_dbl > 30 Then tmp_dbl = 30
ts1.WriteLine Space(4 * 3) & "" & Replace(tmp_dbl, ",", ".") & ""
ts1.WriteLine Space(4 * 3) & "" & ToUTF8("Нет") & ""
End If
ts1.WriteLine Space(4 * 2) & ""
If wa.Cells(ii, 13) <> "" Then 'Дата страхового случая не пустая
ts1.WriteLine Space(4 * 4) & "" & ToUTF8(wa.Cells(ii, mdTags.GetPos("event_description"))) & ""
ts1.WriteLine Space(4 * 4) & "" & Format(wa.Cells(ii, mdTags.GetPos("event_date")), "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 4) & "0"
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & "" & Replace(wa.Cells(ii, mdTags.GetPos("estimation_value")), ",", ".") & ""
ts1.WriteLine Space(4 * 5) & "" & Format(wa.Cells(ii, mdTags.GetPos("payment_date")), "yyyy-mm-dd") & ""
ts1.WriteLine Space(4 * 5) & "" & Replace(wa.Cells(ii, mdTags.GetPos("payment_val")), ",", ".") & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
Else
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 4) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 5) & ""
ts1.WriteLine Space(4 * 4) & ""
End If
ts1.WriteLine Space(4 * 3) & ""
If Not (curdog = wa.Cells(ii + 1, mdTags.GetPos("number")) And cursub = wa.Cells(ii + 1, mdTags.GetPos("subject_name")) And curreg = wa.Cells(ii + 1, mdTags.GetPos("region"))) Then
ts1.WriteLine Space(4 * 2) & ""
End If
If curdog <> wa.Cells(ii + 1, mdTags.GetPos(
