[dyshes90]

Iska, На самом деле круто, спасибо, только нужно чтобы это все графически выводилось, а не в окне отладки.

[Iska]

Если опишете и покажете, как именно надо — попробуем. Сразу скажу, что вариант «Всё на том же листе в виде подтаблиц» мне не сильно нравится.

Конечная цель этих действий какова вообще?

[dyshes90]

Я скинул файл вчера, как сам навоял, я таблицу раскидал по разным листам......было бы не плохо, чтобы макрос выкидвал эту таблицу на другой лист в таком примерно виде

[Iska]

Попробуйте так (замените существующую процедуру «Sample()»):

Скрытый текст

Код:

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

[dyshes90]

Iska, Хорошо, будь другом, подскажи если знаешь, как сделать, надо закрасить ячейки на против цифр, причем диапазон цифр может меняться, нужна процедура, при нажатии на кнопку он просматривал столбец находил цифру 1 и закрашивал рядом стоящую ячейку

[dyshes90]

У же не надо, сам решил, спасибо)

[Iska]

У же не надо, сам решил, спасибо) »

Это хорошо, потому как я ничего толком не понял .