Attribute VB_Name = "Модуль2"
Option Explicit
Sub MakeGroupReport()
Dim odbcDriver As String, odbcstr As String, qt As Object, addGroupModule As String
    DataStartRow = 30
    GroupStartRow = 10
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    repPath = Trim(ThisWorkbook.Sheets(1).[A2].Value)
    repPath = repPath + IIf(repPath <> "", IIf(Mid(repPath, Len(repPath), 1) = "\", "", "\"), "")
    repName = Trim(ThisWorkbook.Sheets(1).[B2].Value)
    dbPath = Trim(ThisWorkbook.Sheets(1).[C2].Value)
    dbPath = dbPath + IIf(dbPath <> "", IIf(Mid(dbPath, Len(dbPath), 1) = "\", "", "\"), "")
    dbSelect = Trim(ThisWorkbook.Sheets(1).[D2].Value)
    dbSelectGroup = Trim(ThisWorkbook.Sheets(1).[e2].Value)
    addGroupModule = Trim(ThisWorkbook.Sheets(1).[f2].Value)
    ' Открываем шаблон документа
    Workbooks.Open FileName:=repPath + repName
    ' Добавляем модуль FUNCTIONS.BAS
    Application.ActiveWorkbook.VBProject.VBComponents.Import (repPath + "MODULES\function.bas")
    ' Добавили лист для данных
    Application.ActiveWorkbook.Worksheets.Add
    Set wsd = Application.ActiveWorkbook.ActiveSheet
    wsd.Name = "Данные"
    wsd.[A2].Value=repPath
    wsd.[C2].Value=dbPath
    wsd.[D2].Value=dbSelect
    wsd.[F2].Value=addGroupModule
    Set wso = Application.ActiveWorkbook.Worksheets("Документ")
    Set wsh = Application.ActiveWorkbook.Worksheets("Группы")
    wsh.Visible = False
    ' Скопировали лист "Документ" в "Чистый"
    wso.Copy after:=Worksheets("Документ")
    Application.ActiveSheet.Name = "Чистый"
    Application.ActiveSheet.Visible = False
    Worksheets("Документ").Cells.Copy Worksheets("Чистый").Cells
    ' Загружаем группировку
    Application.StatusBar = "Загружаем данные о группировке..."
    odbcDriver = GetODBCDriver()
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    odbcstr = "ODBC;" + _
        "Driver=" + odbcDriver + ";" + _
        "UID=admin;SourceType=DBF;" + _
        "DefaultDir=" + dbPath + "\;" + _
        "DBQ=" + dbPath + "\;" + _
        "SourceDB=" + dbPath + "\;"
    Set qt = wsd.QueryTables.Add(odbcstr, _
        wsd.Cells(GroupStartRow, 1), dbSelectGroup)
    qt.BackgroundQuery = False
    qt.FieldNames = True
    qt.Refresh
    lnCount = qt.ResultRange.Rows.Count
    wsd.[G2].Value=lnCount
    Call t1
    Application.ThisWorkbook.Windows(1).Visible = False
    Application.ThisWorkbook.Saved = True
End Sub

Sub t1()
Dim i As Integer, j As Integer, lcOrder As String, nPos As Integer, fname As String, addGroupModule As String, AddModule
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set wsd = Application.ActiveWorkbook.Worksheets("Данные")
    Set wso = Application.ActiveWorkbook.Worksheets("Документ")
    Set wsh = Application.ActiveWorkbook.Worksheets("Группы")
    lnCount = wsd.[G2].Value
    repPath = wsd.[A2].Value
    addGroupModule = wsd.[F2].Value
    ' Добавляем добавочный модуль 
    Set AddModule = Application.ThisWorkbook.VBProject.VBComponents.Import (repPath + "MODULES\" + addGroupModule)
    j = 1
    nPos = InStr(1, wsd.[D2].Value, "ORDER BY")
    If nPos > 0 Then
        wsd.[D2].Value = Mid(wsd.[D2].Value, 1, nPos - 1)
    End If
    lcOrder = ""
    For i = 1 To lnCount - 1
        If wsd.Cells(i + GroupStartRow, 3).Value > 0 Then
            lcOrder = lcOrder + ", " + wsd.Cells(i + GroupStartRow, 2).Value
        End If
    Next i
    For i = 1 To lnCount - 1
        If wsd.Cells(i + GroupStartRow, 3).Value = 0 Then
            lcOrder = lcOrder + ", " + wsd.Cells(i + GroupStartRow, 2).Value
        End If
    Next i
    If lcOrder <> "" Then
        wsd.[D2].Value = wsd.[D2].Value + " ORDER BY " + Mid(lcOrder, 3)
    End If
    dbPath = wsd.[C2].Value
    dbSelect = wsd.[D2].Value
    Er = 0
    Call LoadData
    If Er = 0 Then
        Application.StatusBar = "Создаем группы..."
        groupCount = wso.[B1].Value
        For i = 1 To lnCount - 1
            If wsd.Cells(i + GroupStartRow, 3).Value = "1" Then
                fname = wsd.Cells(i + GroupStartRow, 2).Value
                Call AddGroup3(fname)
            End If
        Next i
        wso.[B1].Value = groupCount
        wsd.Activate
        ' Удаляем добавочный модуль 
        Application.ThisWorkbook.VBProject.VBComponents.Remove (AddModule)
        ' Преобразование полей
        Call f1
        Call RedefineFields(wso.Cells)
        ' Формирование отчета
        Application.StatusBar = "Формирование документа (0%)"
        nl = 0
        ' Создание нового листа
        Sheets("Документ").Copy Before:=Sheets(1)
        Application.ActiveSheet.Name = "Документ (1)"
        Set wsr = Application.ActiveSheet
        wsr.Rows("1:10000").Delete Shift:=xlUp
        If nxlDateTime Then wsr.PageSetup.RightHeader = "&D  &T"
        curPosR = 1
        Call f2(1)
        Application.StatusBar = False
        ' Создаем свою панель инструментов
        Call InitCBR2
        wsd.Visible = False
        Application.DisplayAlerts = False
        wso.Delete
    Else
        On Error Goto 0
        Application.DisplayAlerts = False
        wso.Parent.Close
    End If
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Visible = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.ActiveWorkbook.Saved = True
    Application.ThisWorkbook.Saved = True
End Sub

Sub AddGroup3(fname As String)
    Call AddGroup2(fname)
End Sub

Sub InitCBR2()
    ' Удаляем старую панель
    Call DeleteCBR("Печать")
    ' Добавляем новую панель
    Application.CommandBars.Add(Name:="Печать", Position:=msoBarTop, Temporary:=True).Visible = True
    Application.CommandBars("Печать").Controls.Add Type:=msoControlButton, Id:= _
        109, Before:=1
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, Id:= _
        2521, Before:=2)
        .Caption = "Печать текущего документа"
    End With
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, _
        Before:=3)
        .FaceId = 160
        .Style = msoButtonIcon
        .Caption = "Печать всех документов"
        .OnAction = "PrintAll"
    End With
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, _
        Before:=4)
        .FaceId = 706
        .Style = msoButtonIcon
        .Caption = "Перегруппировка"
        .OnAction = "Regrouping"
    End With
End Sub

Function IsUpGroup(lcFCol As String) As Boolean
Dim llFound As Boolean, i As Integer
    llFound = False
    For i = 1 To groupCount - 1
        llFound = llFound Or (groupProp(i, 1) = lcFCol)
    Next i
    IsUpGroup = llFound
End Function

Sub Regrouping()
    Load UserForm2
    UserForm2.Show
End Sub

Sub DeleteWorkSheets()
Dim ws As Object
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Mid(ws.Name, 1, 10) = "Документ (" Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
End Sub

