[решено] Создание макроса для поиска одинаковых значений в ячейках и укомплектовывания

[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]

У же не надо, сам решил, спасибо) »
Это хорошо, потому как я ничего толком не понял ;).