Здравствуйте! Подскажите пожалуйста как обработать следующий запрос макросом:
Есть лист с данными (лист2) - общее количество строк изменяется (до 1500 и более) порядок столбцов постоянный лист(1) - форма куда собирается информация при этом формат листа тоже постоянный (в примере я оставила только значимые поля)
требуется собрать в форму на листе 1 данные с листа 2 при выполнении условия совпадения кода статьи и номера проекта при этом данные на листе 2 с одинаковыми параметрами могут быть внесены несколькими записями (их нужно сложить)
нарисовала вот такой макрос (все ссылки на реальные диапазоны) :
Код
Sub Макрос12()
Dim CompareRange As Variant, x As Variant, y As Variant, g As Variant, z As Variant
Dim k As Variant, l As Variant
z = 0
z1 = 0
k = 0
g = 0
Set CompareRange = Worksheets("Лист1").Range("b15:b700")
Worksheets("Лист2").Activate
Worksheets("Лист2").Range("b3:b1125").Select
For Each y In CompareRange
For g = 1 To 15
k = 1
If g Mod 4 = 0 Then g = g + 1
For Each x In Selection
If x = y Then
If y <> 0 Then
If x.Offset(0, -1) = 10100 Then
z = x.Offset(0, 3 + k)
z1 = z1 + z
y.Offset(0, 4 + g) = z1
End If
End If
End If
Next x
z = 0
z1 = 0
Next g
k = k + 1
Next y
Worksheets("Лист1").Activate
End Sub
но он очень медленный, если есть другое решение, то Большое Вам спасибо!
LVL, спасибо Вам за ссылку, но к сожалению не получилось у меня под свои нужды код приспособитьэтот вот кусочек, в форме с итогом данные заносятся в 3 столбец
мне нужно записать сумму не в один столбец а в 12 последовательно... здесь нужен еще один цикл для столбца? и как мне потом данные в форму с итогами вывести Спасибо
Дело в том, что данные по проектам собираются на разных листах, мне бы для начала по одному условию определиться. Эту задачу я могу решить и формулами, но хотелось бы обезопасить свои расчеты от случайных ошибок
Макрос в модуль Лист1, срабатывает при активации данного листа
Код
Private Sub Worksheet_Activate()
Dim iKod As String
Dim KodProect As String
Dim FoundKod As Range
Dim i As Long
Dim iLastRow As Long
Dim FirstKod As String
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
Range("F6:H" & iLastRow).ClearContents
Range("J6:L" & iLastRow).ClearContents
Range("N6:P" & iLastRow).ClearContents
Range("R6:T" & iLastRow).ClearContents
KodProect = Range("E3")
For i = 6 To iLastRow
iKod = Cells(i, 2)
With Sheets("Лист2")
Set FoundKod = .Columns(2).Find(iKod, , xlValues, xlWhole)
If Not FoundKod Is Nothing Then
FirstKod = FoundKod.Address 'адрес первого вхождения кода в столбце В
Do
If .Cells(FoundKod.Row, 1) = KodProect Then
Cells(i, 6) = Cells(i, 6) + .Cells(FoundKod.Row, 5) 'январь
Cells(i, 7) = Cells(i, 7) + .Cells(FoundKod.Row, 6) 'февраль
'для остальных месяцв аналогично
End If
Set FoundKod = .Columns(2).FindNext(FoundKod)
Loop While FoundKod.Address <> FirstKod
End If
End With
Next
Application.ScreenUpdating = True
End Sub
так как у меня данные по проектам на отдельных листах я сделала так:
Код
dd = ActiveSheet.Range("n2")' на листе с данными по проекту имя листа откуда выборку делаем, он общий для всех
With Sheets(dd) ' обращение к этому листу
получается для каждого проекта нужно макрос перезапускать
На Лист2 можно сделать кнопочку, к которой привязать макрос. Макрос циклом пробегает по листам и подтягивает данные с Лист2 на лист соответствующего проекта.
Скрытый текст
Код
Sub Макрос10()
Dim iKod As String
Dim KodProect As String
Dim FoundKod As Range
Dim i As Long
Dim iLastRow As Long
Dim FirstKod As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
For Each Sht In Worksheets
If Sht.Name <> "Лист2" Then ' кроме листа "Лист2"
With Sht
iLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("F6:H" & iLastRow).ClearContents
.Range("J6:L" & iLastRow).ClearContents
.Range("N6:P" & iLastRow).ClearContents
.Range("R6:T" & iLastRow).ClearContents
KodProect = .Range("E3")
For i = 6 To iLastRow
iKod = .Cells(i, 2)
Set FoundKod = Columns(2).Find(iKod, , xlValues, xlWhole)
If Not FoundKod Is Nothing Then
FirstKod = FoundKod.Address 'адрес первого вхождения кода в столбце В
Do
If Cells(FoundKod.Row, 1) = KodProect Then
.Cells(i, 6) = .Cells(i, 6) + Cells(FoundKod.Row, 5) 'январь
.Cells(i, 7) = .Cells(i, 7) + Cells(FoundKod.Row, 6) 'февраль
.Cells(i, 8) = .Cells(i, 8) + Cells(FoundKod.Row, 7) 'март
.Cells(i, 10) = .Cells(i, 10) + Cells(FoundKod.Row, 8) '
.Cells(i, 11) = .Cells(i, 11) + Cells(FoundKod.Row, 9) '
.Cells(i, 12) = .Cells(i, 12) + Cells(FoundKod.Row, 10) '
.Cells(i, 14) = .Cells(i, 14) + Cells(FoundKod.Row, 11) '
.Cells(i, 15) = .Cells(i, 15) + Cells(FoundKod.Row, 12) '
.Cells(i, 16) = .Cells(i, 16) + Cells(FoundKod.Row, 13) '
.Cells(i, 18) = .Cells(i, 18) + Cells(FoundKod.Row, 14) '
.Cells(i, 19) = .Cells(i, 19) + Cells(FoundKod.Row, 15) '
.Cells(i, 20) = .Cells(i, 20) + Cells(FoundKod.Row, 16) '
'для остальных месяцв аналогично
End If
Set FoundKod = Columns(2).FindNext(FoundKod)
Loop While FoundKod.Address <> FirstKod
End If
Next
End With
End If
Next
Application.ScreenUpdating = True
End Sub
For Each Sht In Worksheets
If Sht.Name <> "Лист2" Then ' кроме листа "Лист2"
With Sht
я тоже думала, но у меня в этой книге не только листы с одинаковым форматом, есть еще сводные консолидированные формы и поэтому ссылку на обрабатываемые листы нужно по имени делать или отдельным списком где то их указывать