Код:
Sub Sample()
Dim objConnection As Object
Dim objRecordSet1 As Object
Dim objRecordSet2 As Object
Dim objCurRegion As Range
Dim objWorksheet As Worksheet
Dim objRange As Range
Set objConnection = CreateObject("ADODB.Connection")
With objConnection
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"""
.Open
End With
Set objCurRegion = ThisWorkbook.Worksheets.Item("Адресная программа").Range("B2").CurrentRegion
Set objRecordSet1 = objConnection.Execute( _
"SELECT DISTINCT Наименование " & _
"FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
"WHERE NOT Наименование IS NULL ORDER BY Наименование" _
)
Set objRecordSet2 = objConnection.Execute( _
"SELECT Наименование, Ячейки, Количество " & _
"FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
"WHERE NOT Наименование IS NULL ORDER BY Наименование, Ячейки" _
)
objRecordSet1.MoveFirst
Set objWorksheet = ThisWorkbook.Worksheets.Add()
Set objRange = objWorksheet.Range("A1")
Do Until objRecordSet1.EOF
Set objCurRegion = objRange
objRange.Value = objRecordSet1.Fields.Item("Наименование").Value
With objRecordSet2
.Filter = "Наименование='" & objRecordSet1.Fields.Item("Наименование").Value & "'"
Do Until .EOF
With .Fields
objRange.Offset(0, 1).Value = .Item("Ячейки").Value
objRange.Offset(0, 2).Value = .Item("Количество").Value
End With
.MoveNext
Set objCurRegion = Union(objCurRegion, objRange, objRange.Offset(0, 1), objRange.Offset(0, 2))
Set objRange = objRange.Offset(1, 0)
Loop
End With
With objCurRegion.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objCurRegion.Columns.Item(1)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
objRecordSet1.MoveNext
Set objRange = objRange.Offset(1, 0)
Loop
objWorksheet.Columns("A:C").AutoFit
Set objRange = Nothing
Set objCurRegion = Nothing
Set objWorksheet = Nothing
objRecordSet2.Close
objRecordSet1.Close
objConnection.Close
Set objRecordSet2 = Nothing
Set objRecordSet1 = Nothing
Set objConnection = Nothing
End Sub
