Думаю разеорешься


Public Function excel_Price()

Dim s As String
Dim Lastend, rc, i, j As Integer

Set XL = CreateObject("Excel.Application")
'XL.Workbooks.Add ("C:\Книга1.xls")
XL.Workbooks.Add ("")
XL.Visible = True



Lastend = 20
'Set MainRst = CurrentDb.OpenRecordset("SELECT Distinct MKart.SupplierID FROM MKart order by 1;", dbOpenSnapshot, dbReadOnly, dbReadOnly)
Set MainRst = CurrentDb.OpenRecordset("Groups", dbOpenSnapshot, dbReadOnly, dbReadOnly)

MainRst.MoveFirst
While Not MainRst.EOF
's = "SELECT TNomObj.Cd, TNomObj.Nm, TNomObj.NoMax, TNomObj.NoMin, TSklkrtObj.Cn, TSklkrtObj.Grp FROM TNomObj INNER JOIN TSklkrtObj ON TNomObj.Rcd = TSklkrtObj.RcdNom Where TSklkrtObj.Grp = 28" ' + CStr(MainRst.Fields(1).Value)

Set rst = CurrentDb.OpenRecordset("SELECT TNomObj.Cd, TNomObj.Nm, TNomObj.NoMax, TNomObj.NoMin, TSklkrtObj.Cn, TSklkrtObj.Grp FROM TNomObj INNER JOIN TSklkrtObj ON TNomObj.Rcd = TSklkrtObj.RcdNom Where (TSklkrtObj.Grp = """ + CStr(MainRst.Fields(1).Value) + """)", dbOpenSnapshot, dbReadOnly, dbReadOnly)

'Set Rst = CurrentDb.OpenRecordset("Таблица2")
If rst.RecordCount > 0 Then
rst.MoveLast
rst.MoveFirst
rc = rst.Fields.Count

j = 1

ReDim ar(1 To rst.RecordCount, 1 To rst.Fields.Count) As Variant

While Not rst.EOF
For i = 0 To rc - 1
ar(j, i + 1) = rst.Fields(i).Value
Next i
j = j + 1
rst.MoveNext
Wend
'Вывод на экран
Call OutPut(Array(MainRst.Fields(1).Value, MainRst.Fields(2).Value, "", "", "", "", ""), adres(Lastend, 1, 1, 7), "Times New Roman", 12, False, False, True, True, False)
Lastend = Lastend + 1

Call OutPut(ar, adres(Lastend, 1, rst.RecordCount, rst.Fields.Count), "Times New Roman", 10, True, True, Flase, False, False)
Lastend = Lastend + rst.RecordCount
'отступ между группами
Lastend = Lastend + 2
rst.Close
End If
MainRst.MoveNext
Wend
End Function


Public Sub OutPut(ar, adrstr, FontName, FontSize, Abris, AutFit, Bold, Italic, Under)
XL.ActiveWorkbook.Worksheets(1).Range(adrstr).Value = ar
XL.ActiveWorkbook.Worksheets(1).Range(adrstr).Select
If Abris = True Then
XL.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
XL.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With XL.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With XL.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With XL.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With XL.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
If XL.Selection.Columns.Count > 1 Then
With XL.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
If XL.Selection.rows.Count > 1 Then
With XL.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
End If
XL.Selection.Font.Name = FontName
XL.Selection.Font.Size = FontSize
If AutFit = True Then
Call XL.Selection.Columns.AutoFit
End If
XL.Selection.Font.Bold = Bold
XL.Selection.Font.Italic = Italic
If Under = True Then
XL.Selection.Font.Underline = 2
End If
End Sub