Есть таблица по заводам примерно 4000 строк на 20 столбцов в которой идет товарная сетка по каждому заводу на каждый день, в конце идет подсчет на каждый день работы Есть разные характеристики подсчета
Как подсчитать автоматический поле "прибыль" общее для всех при условие что есть различие по "Заводам"
Через суммаесли и суммаеслимн у меня к сожалению не получилось Подобный пример за 3 часа поиска найти не смог(
Макросы писать не умею
Помогите пожалуйста
Еще нашел вот такой пример, но не понимаю как его применить к себе так как не понимаю формулы =СУММ(ЕСЛИ(ЕЧИСЛО(ПОИСК("Колонна";A3:O77));C5:Q79))
Как подсчитать автоматический поле "прибыль" общее для всех при условие что есть различие по "Заводам"
Код
Sub Profit()
Dim i As Long
Dim FoundCell As Range
Dim Zavod As String
Dim FAdr As String
Dim iSumma As Double
For i = 6 To 7
iSumma = 0
Zavod = Replace(Split(Cells(3, i), " ", 3)(2), " ", "")
Set FoundCell = Columns(2).Find(Zavod, , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
Do
iSumma = iSumma + FoundCell.Offset(3, 1)
Set FoundCell = Columns(2).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
Cells(4, i) = iSumma
End If
Next
End Sub
Kuzmich, там не всюду прибыль в FoundCell.Offset(3, 1) И более того, не всюду ЗаводХ, но это может ошибка примера...
Можно так, из результатов чуть доработав код можно куда угодно выбрать нужное:
Код
Option Explicit
Option Compare Text
Sub tt()
Dim t$, i&
With CreateObject("Scripting.Dictionary")
For i = 3 To 52
If Cells(i, 2) Like "з*" Then
t = Cells(i, 2)
Else
.Item(t & " " & Cells(i, 2)) = .Item(t & " " & Cells(i, 2)) + Cells(i, 3)
End If
Next
[f10].Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
End With
End Sub
Kuzmich написал: В вашем примере нет разделения прибыли по заводам
- как это нет? Тут есть всё! Завод1 Транспорт 200 Завод1 Склад 200 Завод1 Прибыль 500 Завод1 0 Завод2 Транспорт 250 Завод2 Склад 250 Завод2 Прибыль 1000 Завод2 0 Звод2 Прибыль 200 Звод2 0
Kuzmich, Hugo Ой, спасибо большое. НО ваши варианты слишком умные для меня.... Боюсь у меня не хватит знаний вставить это к себе Когда я говорил что не умею писать макросы, я имел ввиду что я даже не понимаю как их подставлять и редактировать под себя =)
Hugo, Я вставил в макросы твой код, он вроде вывел результат, помоги пожалуйста его настроить под себя Я достаточно условно обозначил "Заводы" Название у Заводов разное Конкретно у меня 4 завода Останкино Молти Росагроэкспорт Савушкин
Поле "прибыль" Расположено на ниже вроде как на 12 клеток ( для примера название "завода" в строке №1 тогда "прибыль" будет в строке № 13)
Sub tt()
Dim t$, i&
With CreateObject("Scripting.Dictionary")
For i = 3 To 52
If Cells(i, 3) = "" Then
t = Cells(i, 2)
Else
.Item(t & " " & Cells(i, 2)) = .Item(t & " " & Cells(i, 2)) + Cells(i, 3)
End If
Next
[f10].Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
End With
End Sub
Цикл конечно в реальном файле нужен не от 3 To 52... Последнюю строку тоже можно определить макросом. Ну и выгрузку сделать например в K1 и затем отфильтровать все строки где есть прибыль. А если отбирать тут же в макросе - делаете цикл по ключам, если в ключе есть "Прибыль", то выгружаете на лист ключ и его итем.
Код
Sub tt()
Dim t$, i&, k
With CreateObject("Scripting.Dictionary")
For i = 3 To 52
If Cells(i, 3) = "" Then
t = Cells(i, 2)
Else
.Item(t & " " & Cells(i, 2)) = .Item(t & " " & Cells(i, 2)) + Cells(i, 3)
End If
Next
i = 0
For Each k In .keys
If k Like "*Прибыль" Then
i = i + 1
Cells(i, 11).Resize(, 2) = Array(k, .Item(k))
End If
Next
End With
End Sub
Но пример конечно нужно показывать реальный, только покороче и без "личных" данных, ибо думаю что на реальном файле всё равно не взлетит, как бы мы тут не расписывались по этому куцему примеру.
Hugo, вот реальный пример таблицы сверху идет расчеты снизу сводная таблица по каждому заводу Вот мне нужно чтобы в сводную таблицу в заданные места проставлялись суммы по прибыли по каждому заводу отдельно...как то так
Вообще и из г... можно сделать конфетку, но сперва избавьтесь от всех ошибок в формулах! Надеюсь что в реальном файле ошибок нет. Ну а диапазон уж тут придётся задавать в коде явно. Хотя можно конечно поискать где находится "СВОДДНАЯ ТАБЛИЦА"... Но ведь в реальном файле такого нет... Или есть?
Код
Sub tt()
Dim t$, i&, k
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 3 To 209
If Len(Trim(Cells(i, 1))) > 0 And Len((Cells(i, 4).Text)) = 0 Then
t = Cells(i, 1)
Else
.Item(t & " " & Cells(i, 1)) = .Item(t & " " & Cells(i, 1)) + Cells(i, 4)
End If
Next
For i = 213 To 211 + [a212].CurrentRegion.Rows.Count
k = Cells(i, 1) & " прибыль"
Cells(i, 6) = .Item(k)
Next
End With
End Sub
Hugo написал: но сперва избавьтесь от всех ошибок в формулах! Надеюсь что в реальном файле ошибок нет.
ошибок нет, это просто я так отредактировал а скорую руку, так все считается нормальной
Цитата
Hugo написал: Хотя можно конечно поискать где находится "СВОДДНАЯ ТАБЛИЦА"... Но ведь в реальном файле такого нет... Или есть?
нет, это табличка каждый раз вставляется в конце месяца, и может быть как 3000 строк так и 10000 строк на листе
Цитата
Hugo написал: Если в сводной уже забиты все заводы, и их менять местами нельзя - тоже есть вариант: цикл по сводной, формируем ключ, по ключу извлекаем данные из словаря. Лень просто это писать было...
Sub Profit()
Dim i As Long
Dim FoundCell As Range
Dim Zavod As String
Dim iSumma As Double
Dim SvodTablRow As Long
SvodTablRow = Columns("A").Find("СВОДДНАЯ ТАБЛИЦА", , xlValues, xlWhole).Row
Range("F" & SvodTablRow + 1 & ":F" & SvodTablRow + 4).ClearContents
For i = SvodTablRow + 1 To SvodTablRow + 4
iSumma = 0
Zavod = Cells(i, "A") & " Итого"
Set FoundCell = Range("A4:A" & SvodTablRow).Find(Zavod, , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
iSumma = iSumma + FoundCell.Offset(12, 3)
Cells(i, "F") = iSumma
End If
Next
End Sub
Я уже чуть подкорректировал код, теперь выгружает к каждому конкретному заводу, скопируйте код ещё раз. Ну а насчёт поиска сводной - в коде имеет значение каждый символ... я не уверен что он найдёт своддную.
Sub tt()
Dim x&, t$, i&, k
Const s$ = "СВОДДНАЯ ТАБЛИЦА"
On Error Resume Next
x = Cells.Find(s).Row
On Error GoTo 0
If x > 0 Then
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 3 To x - 1
If Len(Trim(Cells(i, 1))) > 0 And Len((Cells(i, 4).Text)) = 0 Then
t = Cells(i, 1)
Else
.Item(t & " " & Cells(i, 1)) = .Item(t & " " & Cells(i, 1)) + Cells(i, 4)
End If
Next
For i = x + 1 To x - 1 + Range("A" & x).CurrentRegion.Rows.Count
k = Cells(i, 1) & " прибыль"
Cells(i, 6) = .Item(k)
Next
End With
Else
MsgBox "На листе нет ячейки с значением " & s, vbCritical
End If
End Sub