День добрый.
Выгружаю в Excel массив данных с группировкой.
т.к. модуль заимствованный а знаний в этом направлении мало, не могу понять как убрать отступы от левого края (см. картинку).
Спасибо.
'Важно: должны быть установлены ссылки на DAO и на Excel object library
'Группировка в отчетах создается на ходу подразумевая настроенную в запросе сортировку по группам
Option Compare Database
Option Explicit
Const ReportTblName = "xОтчеты"
Const HeaderTblName = "xЗаголовок отчета"
Const FieldTblName = "xПоля"
Const ParameterTblName = "xПараметры запроса"
Public xl As Excel.Application
Public xlWb As Workbook
Public xlWs As Worksheet
Public R As Range
Private MainTotal As Integer
' Declare necessary API routines:
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Type HeaderType
Text As String
Row As Integer
Col As Integer
Align As Long '0;Лево;1;Центр;2;Право
Bold As Integer
End Type
Private Type PageSetupType
Init As Integer
LeftMargin As Double
RightMargin As Double
TopMargin As Double
BottomMargin As Double
HeaderMargin As Double
FooterMargin As Double
Orientation As Long
End Type
Private Type FieldType
Value As Variant
PrevValue As Variant
Name As String
Head As String
Status As Integer
Col As Integer
Width As Long
Align As Long '0;Лево;1;Центр;2;Право
Format As String '0;Групировка;1;Итог;2;Значение
SubTotals As Integer
IndentLevel As Integer
End Type
Private Type GroupType
N As Integer
Row As Integer
Value As Variant
End Type
Public Ind As Long 'Индекс в БД
Public QueryName As String 'Имя запроса
Public Qd As DAO.QueryDef
Public Sort As String
Private Rs As DAO.Recordset
Private RsTemp As DAO.Recordset
Private QdTemp As DAO.QueryDef
Private Nm As String 'Имя отчета
Private TmplName As String 'Имя шаблона
Private StartTblRow As Integer
Private AllowColumnNames As Integer
Private FontName As Variant
Private FontSize As Variant
Private PageSetup As PageSetupType
Private CurRow As Long 'Текущая строка
Private Bold As Integer 'Итоги жирно
Private Headers() As HeaderType
Private HeaderCount As Integer
Private Totals() As Integer 'Номера полей, являющихся итогами
Private TotalCount As Integer
Private FirstGroups As Integer
Private Groups() As GroupType 'Номера полей, являющихся группами
Private GroupCount As Integer
Private Formulas() As String 'формулы итогов в группах (Группа, Итог)
Private Fields() As FieldType
Private FieldCount As Integer
Private sRow As Integer
Private eRow As Integer
Private sCol As Integer
Private eCol As Integer
Private TblRow As Integer
Public Property Set Recordset(RsIn As Recordset)
Set Rs = RsIn.Clone
If Rs.RecordCount <> 0 Then
Rs.MoveFirst
End If
End Property
Public Property Get Recordset()
Set Recordset = Rs
End Property
Public Property Get HeaderCol(ByVal i As Integer) As Integer
HeaderCol = Headers(i).Col
End Property
Public Property Let HeaderCol(ByVal i As Integer, ByVal Col As Integer)
Headers(i).Col = Col
End Property
Public Property Get HeaderRow(ByVal i As Integer) As Integer
HeaderRow = Headers(i).Row
End Property
Public Property Let HeaderRow(ByVal i As Integer, ByVal Row As Integer)
Headers(i).Row = Row
End Property
Public Property Get HeaderText(ByVal i As Integer) As String
HeaderText = Headers(i).Text
End Property
Public Property Let HeaderText(ByVal i As Integer, ByVal Text As String)
Headers(i).Text = Text
End Property
Public Sub ResetHeaders(Optional ByVal N As Integer = 0)
Dim i As Integer
Erase Headers
HeaderCount = N
If N > 0 Then
ReDim Headers(1 To N)
For i = 1 To HeaderCount
Headers(i).Align = xlHAlignLeft
Headers(i).Bold = True
Next i
End If
End Sub
Public Sub EraseFields()
Erase Totals
TotalCount = 0
Erase Groups
GroupCount = 0
Erase Formulas
Erase Fields
FieldCount = 0
End Sub
Public Property Get Name() As String
Name = Nm
End Property
Public Sub LoadHeaders()
Dim Rs As DAO.Recordset
Dim i As Integer
Set Rs = CurrentDb.OpenRecordset("Select * from [" + HeaderTblName + "] Where [Отчет]=" + CStr(Ind), dbOpenDynaset, dbSeeChanges)
If Rs.RecordCount = 0 Then
ResetHeaders
Rs.Close
Exit Sub
End If
Rs.MoveLast
ResetHeaders Rs.RecordCount
Rs.MoveFirst
For i = 1 To HeaderCount
Headers(i).Text = Nz(Rs![Текст], "")
If Rs![Выравнивание] = 1 Then
Headers(i).Align = xlHAlignCenter
ElseIf Rs![Выравнивание] = 2 Then
Headers(i).Align = xlHAlignRight
Else
Headers(i).Align = xlHAlignLeft
End If
Headers(i).Col = Rs![Столбец]
Headers(i).Row = Rs![Строка]
Headers(i).Bold = Nz(Rs![Жирность], False)
Rs.MoveNext
Next i
Rs.Close
End Sub
Public Property Let Name(ByVal SNm As String)
Dim Rs As DAO.Recordset
Set Rs = CurrentDb.OpenRecordset("select * from [" + ReportTblName + "] where [Наименование]='" + SNm + "'", dbOpenDynaset, dbSeeChanges)
If Rs.RecordCount = 0 Then
Rs.Close
Err.Raise 513, , "Отчет не найден"
Exit Property
End If
Ind = Rs![Индекс]
Bold = Nz(Rs![Группы жирно], False)
QueryName = Nz(Rs![Запрос], "")
FontName = Nz(Rs![Шрифт], "Ms SansSerif")
FontSize = Nz(Rs![Размер], 8)
TmplName = Nz(Rs![Шаблон], "")
StartTblRow = Nz(Rs![Первая строка], 0)
AllowColumnNames = Rs![Заголовки столбцов]
If Rs![Итог] = True Then
MainTotal = 0
Else
MainTotal = -1
End If
PageSetup.Init = True
If IsNumeric(Rs!LeftMargin) Then
PageSetup.LeftMargin = Rs!LeftMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!RightMargin) Then
PageSetup.RightMargin = Rs!RightMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!TopMargin) Then
PageSetup.TopMargin = Rs!TopMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!BottomMargin) Then
PageSetup.BottomMargin = Rs!BottomMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!HeaderMargin) Then
PageSetup.HeaderMargin = Rs!HeaderMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!FooterMargin) Then
PageSetup.FooterMargin = Rs!FooterMargin
Else
PageSetup.Init = False
End If
If IsNumeric(Rs!Orientation) Then
PageSetup.Orientation = Rs!Orientation
Else
PageSetup.Init = False
End If
Nm = SNm
If QueryName <> "" Then
Set Qd = CurrentDb.QueryDefs(QueryName)
Else
Set Qd = Nothing
End If
ResetHeaders 0
EraseFields
LoadFields
Sort = ""
End Property
Public Sub LoadFields()
Dim Rs As DAO.Recordset
Dim i As Integer
Dim K As Integer
Dim M As Integer
Dim li As Integer
Dim Col As Integer
EraseFields
Set Rs = CurrentDb.OpenRecordset("Select * from [" + FieldTblName + "] Where [Отчет]=" + CStr(Ind) + " order by [Столбец];", dbOpenDynaset, dbSeeChanges)
If Rs.RecordCount = 0 Then
Rs.Close
Exit Sub
End If
Rs.MoveLast
FieldCount = Rs.RecordCount
ReDim Fields(0 To FieldCount)
Rs.MoveFirst
GroupCount = 0
TotalCount = 0
For i = 1 To FieldCount
Fields(i).Head = Nz(Rs![Заголовок], Rs![Имя])
Fields(i).Name = Rs![Имя]
Fields(i).Format = Nz(Rs![Формат], "General")
Fields(i).Status = Rs![Статус]
Fields(i).Width = Nz(Rs![Ширина], -1)
If Rs![Выравнивание] = 1 Then
Fields(i).Align = xlHAlignCenter
ElseIf Rs![Выравнивание] = 2 Then
Fields(i).Align = xlHAlignRight
Else
Fields(i).Align = xlHAlignLeft
End If
Fields(i).IndentLevel = 0
If Fields(i).Status = 0 Then
GroupCount = GroupCount + 1
ElseIf Fields(i).Status = 1 Then
TotalCount = TotalCount + 1
End If
Fields(i).Value = 0
Fields(i).PrevValue = 0
Fields(i).SubTotals = Nz(Rs![Итоги], 9)
Rs.MoveNext
Next i
Rs.Close
Fields(0).Align = xlHAlignLeft
Fields(0).Value = "Всего"
Fields(0).Status = 0
Fields(0).Format = "General"
Fields(0).Col = 1
Fields(0).IndentLevel = 0
Col = 1
i = 1
li = 0
While Fields(i).Status = 0
Fields(i).Col = 1
Fields(i).Align = xlHAlignLeft
Fields(i).Head = Fields(1).Head
Fields(i).Width = Fields(1).Width
If Col <= 15 Then
Fields(i).IndentLevel = Col + MainTotal
Else
Fields(i).IndentLevel = 14
End If
li = Fields(i).IndentLevel + 1
i = i + 0
Col = Col + 0
Wend
FirstGroups = Col
Col = 1
For i = FirstGroups To FieldCount
Fields(i).Col = Col
Fields(i).IndentLevel = li
li = 0
Col = Col + 1
Next i
ReDim Groups(0 To GroupCount)
If TotalCount > 0 Then
ReDim Totals(1 To TotalCount)
End If
If TotalCount > 0 Then
ReDim Formulas(0 To GroupCount, 1 To TotalCount)
End If
M = 1
K = 0
For i = 0 To FieldCount
If Fields(i).Status = 0 Then
Groups(K).N = i
K = K + 1
ElseIf Fields(i).Status = 1 Then
Totals(M) = i
M = M + 1
End If
Next i
End Sub
Public Sub LoadParameters()
Dim Rs As DAO.Recordset
On Error Resume Next
Set Rs = CurrentDb.OpenRecordset("Select * from [" + ParameterTblName + "] Where [Отчет]=" + CStr(Ind), dbOpenDynaset, dbSeeChanges)
While Not Rs.EOF
If Rs![Тип] = 0 Then
Qd.Parameters(Rs![Имя]) = CLng(Rs![Значение])
ElseIf Rs![Тип] = 1 Then
Qd.Parameters(Rs![Имя]) = CDbl(Rs![Значение])
ElseIf Rs![Тип] = 2 Then
Qd.Parameters(Rs![Имя]) = CDate(Rs![Значение])
Else
Qd.Parameters(Rs![Имя]) = Rs![Значение]
End If
Rs.MoveNext
Wend
Rs.Close
End Sub
Private Sub Class_Initialize()
Set Qd = Nothing
Set Rs = Nothing
Set xl = Nothing
Set xlWb = Nothing
Set R = Nothing
Sort = ""
FontSize = Null
ResetHeaders
EraseFields
End Sub
Private Sub Class_Terminate()
Set Qd = Nothing
Set Rs = Nothing
Set Qd = Nothing
Set Rs = Nothing
Set xl = Nothing
Set xlWb = Nothing
Set R = Nothing
ResetHeaders
EraseFields
End Sub
Private Function AddXlSheet() As Integer
xl.Visible = False
DoEvents
AddXlSheet = False
On Error Resume Next
If TmplName <> "" Then
Set xlWs = xlWb.Sheets.Add(Type:=TmplName, after:=xlWs)
Else
Set xlWs = xlWb.Add
End If
If Err.Number = 0 Then
AddXlSheet = True
End If
Set R = xlWs.Cells
SetXlSizes
Err.Clear
End Function
Private Sub InitXlObjects()
Dim i As Integer
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xl = CreateObject("Excel.Application")
End If
DetectExcel
On Error GoTo 0
xl.Visible = False
If TmplName <> "" Then
Set xlWb = xl.Workbooks.Add(TmplName)
Set xlWs = xlWb.Sheets(1)
Else
Set xlWb = xl.Workbooks.Add
Set xlWs = xlWb.ActiveSheet
End If
Set R = xlWs.Cells
SetXlSizes
CurRow = 1
End Sub
Private Sub SetXlSizes()
Dim i As Integer
xlWs.Outline.SummaryRow = xlAbove
xlWs.Outline.SummaryColumn = xlRight
xlWs.Outline.AutomaticStyles = False
If TmplName <> "" Then
Exit Sub
End If
If Nz(FontName, "") <> "" Then
R.Font.Name = FontName
End If
If IsNumeric(FontSize) Then
R.Font.Size = FontSize
End If
If PageSetup.Init Then
xlWs.PageSetup.LeftMargin = PageSetup.LeftMargin
xlWs.PageSetup.RightMargin = PageSetup.RightMargin
xlWs.PageSetup.TopMargin = PageSetup.TopMargin
xlWs.PageSetup.BottomMargin = PageSetup.BottomMargin
xlWs.PageSetup.HeaderMargin = PageSetup.HeaderMargin
xlWs.PageSetup.FooterMargin = PageSetup.FooterMargin
xlWs.PageSetup.Orientation = PageSetup.Orientation
End If
For i = 1 To FieldCount
If Fields(i).Width >= 0 Then
R.Columns(Fields(i).Col).ColumnWidth = Fields(i).Width
End If
Next i
End Sub
Private Sub OpenRecordset()
Dim i As Integer
If Not Rs Is Nothing Then
Exit Sub
End If
If Sort <> "" Then
Set QdTemp = CurrentDb.CreateQueryDef("", "Select * From [" + Qd.Name + "] order by " + Sort)
For i = 0 To Qd.Parameters.Count - 1
QdTemp.Parameters(Qd.Parameters(i).Name) = Qd.Parameters(i)
Next i
Set Rs = QdTemp.OpenRecordset
Else
Set Rs = Qd.OpenRecordset
End If
End Sub
Private Sub FlashHeaders()
Dim i As Integer
For i = 1 To HeaderCount
R(Headers(i).Row, Headers(i).Col).Value = Headers(i).Text
R(Headers(i).Row, Headers(i).Col).HorizontalAlignment = Headers(i).Align
R(Headers(i).Row, Headers(i).Col).Font.Bold = Headers(i).Bold
If CurRow < Headers(i).Row Then
CurRow = Headers(i).Row
End If
Next i
CurRow = CurRow + 1
End Sub
Private Sub FlashTableHeaders()
Dim i As Integer
If AllowColumnNames <> True Then
Exit Sub
End If
For i = 1 To FieldCount
R(CurRow, Fields(i).Col).Value = Fields(i).Head
R(CurRow, Fields(i).Col).HorizontalAlignment = xlHAlignCenter
R(CurRow, Fields(i).Col).VerticalAlignment = xlVAlignCenter
R(CurRow, Fields(i).Col).Font.Bold = True
R(CurRow, Fields(i).Col).Borders.LineStyle = xlContinuous
R(CurRow, Fields(i).Col).Borders.Weight = xlThin
R(CurRow, Fields(i).Col).Interior.Color = 16777164
R(CurRow, Fields(i).Col).WrapText = True
Next i
CurRow = CurRow + 1
End Sub
Private Sub LoadFieldValues()
Dim i As Integer
For i = 1 To FieldCount
If Left(Fields(i).Name, 1) <> "=" Then
Fields(i).Value = Rs.Fields(Fields(i).Name)
ElseIf Mid(Fields(i).Name, 2, 1) = "#" Then
Fields(i).Value = TblRow
Else
Fields(i).Value = Mid(Fields(i).Name, 2)
End If
Next i
End Sub
Private Sub InitGroups(ByVal lev As Integer)
Dim i As Integer
Dim j As Integer
Dim M As Integer
If lev <= GroupCount Then
For i = 1 To FieldCount
Fields(i).PrevValue = 0
Next i
End If
If lev = 0 And MainTotal = -1 Then
Exit Sub
End If
If GroupCount = 0 And TotalCount = 0 Then
Exit Sub
End If
For i = lev To GroupCount
Groups(i).Row = CurRow
M = Groups(i).N
Groups(i).Value = Fields(M).Value
R.Rows(CurRow).OutlineLevel = i + 1 + MainTotal '12/07
R.Rows(CurRow).Font.Bold = Bold
R(CurRow, Fields(M).Col).Value = Fields(M).Value
R(CurRow, Fields(M).Col).HorizontalAlignment = Fields(M).Align
If Fields(M).IndentLevel <> 0 Then
R(CurRow, Fields(M).Col).IndentLevel = Fields(M).IndentLevel
End If
R(CurRow, Fields(M).Col).NumberFormat = Fields(M).Format
For j = 1 To TotalCount
M = Totals(j)
R(CurRow, Fields(M).Col).HorizontalAlignment = Fields(M).Align
If Fields(M).IndentLevel <> 0 Then
R(CurRow, Fields(M).Col).IndentLevel = Fields(M).IndentLevel
End If
R(CurRow, Fields(M).Col).NumberFormat = Fields(M).Format
Formulas(i, j) = "=SUBTOTAL(" + CStr(Fields(M).SubTotals) + "," + Rc(1, 0) + ":"
Next j
CurRow = CurRow + 1
Next i
End Sub
Private Sub FlashFields()
Dim i As Integer
On Error Resume Next
R.Rows(CurRow).Font.Bold = False
' R.Rows(CurRow).OutlineLevel = GroupCount + 2 ' Дерево свернуто
R.Rows(CurRow).OutlineLevel = GroupCount ' Дерево развернуто
For i = FirstGroups To FieldCount
R(CurRow, Fields(i).Col).NumberFormat = Fields(i).Format
R(CurRow, Fields(i).Col).HorizontalAlignment = Fields(i).Align
If Fields(i).IndentLevel <> 0 Then
R(CurRow, Fields(i).Col).IndentLevel = Fields(i).IndentLevel
End If
If Fields(i).Status = 4 Then
Fields(i).PrevValue = Fields(i).PrevValue + Fields(i).Value
R(CurRow, Fields(i).Col).Value = Fields(i).PrevValue
Else
R(CurRow, Fields(i).Col).Value = Fields(i).Value
End If
Next i
CurRow = CurRow + 1
End Sub
Private Sub CloseGroups(ByVal lev As Integer)
Dim i As Integer
Dim j As Integer
On Error Resume Next
If GroupCount = 0 And TotalCount = 0 Then
Exit Sub
End If
If MainTotal = -1 And lev = 0 Then
Exit Sub
End If
For i = GroupCount To lev Step -1
For j = 1 To TotalCount
Formulas(i, j) = Formulas(i, j) + Rc(CurRow - Groups(i).Row - 1, 0) + ")"
R(Groups(i).Row, Fields(Totals(j)).Col).FormulaR1C1 = Formulas(i, j)
Next j
Next i
End Sub
Private Function Rc(ByVal Row As Integer, ByVal Col As Integer) As String
Rc = "R[" + CStr(Row) + "]C[" + CStr(Col) + "]"
End Function
Private Sub FlashTable()
Dim i As Integer
Dim Flag As Integer
If Qd Is Nothing Then
Exit Sub
End If
OpenRecordset
If Rs.EOF Then
Rs.Close
Exit Sub
End If
If StartTblRow > 0 Then
CurRow = StartTblRow
sRow = CurRow
Else
sRow = CurRow - 1
End If
TblRow = 1
LoadFieldValues
InitGroups 0
While Not Rs.EOF
LoadFieldValues
Flag = True
i = 1
While Flag And (i <= GroupCount)
' группы одинаковые, если значение полей совпадают или Null
If Groups(i).Value = Fields(Groups(i).N).Value Or (IsNull(Groups(i).Value) And IsNull(Fields(Groups(i).N).Value)) Then
i = i + 1
Else
Flag = False
End If
Wend
CloseGroups i
InitGroups i
FlashFields
Rs.MoveNext
TblRow = TblRow + 1
Wend
CloseGroups -MainTotal
eRow = CurRow - 1
sCol = 1
eCol = Fields(FieldCount).Col
Rs.Close
R.Range(R(sRow, sCol), R(eRow, eCol)).Borders.LineStyle = xlContinuous
R.Range(R(sRow, sCol), R(eRow, eCol)).Borders.Weight = xlThin
End Sub
Public Sub MakeXReport(Optional ByVal NewSheet As Integer = False)
If NewSheet = False Then
InitXlObjects
ElseIf AddXlSheet() = False Then
InitXlObjects
End If
FlashHeaders
FlashTableHeaders
FlashTable
xlWs.Outline.ShowLevels 2
xl.Visible = True
End Sub
Public Sub SaveColWidth()
Dim Rs As DAO.Recordset
Dim i As Integer
On Error GoTo errcwEnd
For i = 1 To FieldCount
Fields(i).Width = 0 ' R.Columns(Fields(i).Col).ColumnWidth
Next i
PageSetup.LeftMargin = xlWs.PageSetup.LeftMargin
PageSetup.RightMargin = xlWs.PageSetup.RightMargin
PageSetup.TopMargin = xlWs.PageSetup.TopMargin
PageSetup.BottomMargin = xlWs.PageSetup.BottomMargin
PageSetup.HeaderMargin = xlWs.PageSetup.HeaderMargin
PageSetup.FooterMargin = xlWs.PageSetup.FooterMargin
PageSetup.Orientation = xlWs.PageSetup.Orientation
PageSetup.Init = True
Set Rs = CurrentDb.OpenRecordset("Select * from [" + FieldTblName + "] Where [Отчет]=" + CStr(Ind) + " order by [Столбец];", dbOpenDynaset, dbSeeChanges)
For i = 1 To FieldCount
Rs.Edit
Rs![Ширина] = Fields(i).Width
Rs.Update
Rs.MoveNext
Next i
Rs.Close
Set Rs = CurrentDb.OpenRecordset("Select * from [" + ReportTblName + "] Where [Индекс]=" + CStr(Ind), dbOpenDynaset, dbSeeChanges)
Rs.Edit
Rs!LeftMargin = PageSetup.LeftMargin
Rs!RightMargin = PageSetup.RightMargin
Rs!TopMargin = PageSetup.TopMargin
Rs!BottomMargin = PageSetup.BottomMargin
Rs!HeaderMargin = PageSetup.HeaderMargin
Rs!FooterMargin = PageSetup.FooterMargin
Rs!Orientation = PageSetup.Orientation
Rs.Update
Rs.Close
errcwEnd:
End Sub
Sub DetectExcel() ' откуда-то слямзил фирменный код - якобы позволяет не глючить каким-то версиям Excel (корректно отрабатывать GetObject)
' Procedure dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hwnd As Long
' If Excel is running this API call returns its handle.
hwnd = FindWindow("XLMAIN", 0)
If hwnd = 0 Then ' 0 means Excel not running.
Exit Sub
Else
' Excel is running so use the SendMessage API
' function to enter it in the Running Object Table.
SendMessage hwnd, WM_USER + 18, 0, 0
End If
End Sub
Public Property Let CellVal(ByVal Row As Integer, ByVal Col As Integer, CellValue As Variant)
R(Row, Col).Value = CellValue
End Property
Public Property Get CellVal(ByVal Row As Integer, ByVal Col As Integer) As Variant
CellVal = R(Row, Col).Value
End Property
http://www.sql.ru/forum/1265714/vygruzka-v-excel-pomogite-razobratsya-s-chuzhim-kodom
