Давеча попали ко мне исходные данные в виде exel-файлов, в которых значения представлены нарастающим итогом (каждое значение за месяц равно значению за месяц + сумме значений всех месяцев, что до него). Данные нужны были срочно по каждому периоду, т.е. нужно в екселе получить значения по периодам, используя имеющийся нарастающий итог.
Внезапно не смог обнаружить на просторах сети решение этой несложной задачки. Тряхнул стариной VBA и накропал код, который влепил кнопке.
Мои задачи код решил. Пусть он поможет и другим.
Код со вложенными циклами и при должной оптимизации можно получить более шустрый и универсальный код. Готовый файл со всеми коменатми будет в аттаче.
Поехали.
Условия правильного расчета скриптом из нарастающего итога в обратную сторону.
1. Не менять последовательность столбов! (код можно дополнить и тогда можно будет менять).
2. Типы данных в ячейках д.б. числовые! (важно т.к. строка, в которой цифры будет давать ошибку типов. (код можно оптимизировать проверять типы и приводить все к цифрам).
3. Нет никаких фильтров (код можно дополнить и убирать фильтры).
4. Все новые столбы добавлять только в конец (т.к. п.1).
5. Если помесячная последовательно данных сбита (т.е. например, есть данные на Янв. Фев. … Апр. без марта, то расчета на апрель не будет — установка «нд» — нет данных в смысле нет записей в таблице, если записи есть, но в них нет значение то простановка нулей).
6. Сортировка м.б. любая.
7. Минусовые значения показывают, что данные некорректные (неправильный нарастающий итог: после меньше чем до).
Часть идей слямзил с этого коллеги. За что ему благодарствие.
Function SearchPrevValue(j, m As Long) As Variant
'поиск значения следующего квартала
'доп. коменты по переменным см. в процедуре BackCumulaive()
Dim Sheet1_WS, Sheet2_WS As Worksheet
Dim FinalRow, FinalColumn As Long
Set Sheet1_WS = Application.ThisWorkbook.Sheets(1)
FinalRow = Sheet1_WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
FinalColumn = Sheet1_WS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
'зазкачик
Dim ZG As String
'расход
Dim rash As String
'номер
Dim num_mer As String
'дата
Dim date_ref As Variant
'для цикла
Dim i As Long
'для номера месяца
Dim k As Integer
'диапазон ячеек
Dim R_data As Variant
R_data = Sheet1_WS.Range(Sheet1_WS.Cells(1, 1), Sheet1_WS.Cells(FinalRow, FinalColumn))
SearchPrevValue = Null
'сохраняем текущие значения (можно передать в саму функцию)
'тримим строки, чтобы убрать лишние пробелы
date_ref = R_data(j, 1)
ZG = Application.Trim(R_data(j, 2))
rash = Application.Trim(R_data(j, 5))
num_mer = Application.Trim(R_data(j, 3))
'номер месяца
k = Month(date_ref)
'далее ищем значение предыущего квартала. перебираем все строки.
'IF по-русски: если в текущей строке:
'- месяц из поля "период" (номер столба 1) равен предыдущему от сохраненного
'- год из поля "период" равен сохраненному
'- "заказчик" (номер столба 2) равен сохраненному
'- "странный номер" (номер столба 3) равен сохраненному
'- "статья" (номер столба 5) равен сохраненному
'то возвращаем найденное значение найденной строки и переданного из основной процедуры номера столба
'в IF обязательно включать все условия по которым однозначно выбирается одна единственная строка екселя
'при множественном выборе расчеты будет неправильными, всегда будет использоваться первое найденное значение
'в данном случае IF аналог WHERE в SQL. к-1 = предыдущий месяц
'(если расчет поквартальный или дневной или еще как часть IF надо менять)
For i = 2 To FinalRow 'помчали со второй строки т.к. первая названия полей. не забываем тримить строки
If Month(R_data(i, 1)) = k - 1 And Year(R_data(i, 1)) = Year(date_ref) And Application.Trim(R_data(i, 2)) = ZG And Application.Trim(R_data(i, 3)) = num_mer And Application.Trim(R_data(i, 5)) = rash Then
SearchPrevValue = R_data(i, m) ' нашли, возвращем значение. можно дописать елсеиф для случая "не нашли", но имхо не нужно
Exit Function
End If
Next i
End Function
Sub BackCumulaive()
'рассчет помесячного значения обратного накопительному
'к листам будем обращаться через переменные
Dim Sheet1_WS, Sheet2_WS As Worksheet
'Переменные последней строки и колонки
Dim FinalRow, FinalColumn As Long
'можно инициализировать лист не по названию, а по порядковому номеру
'Set Sheet1_WS = Application.ThisWorkbook.Worksheet("Sheet1")
Set Sheet1_WS = Application.ThisWorkbook.Sheets(1)
'поиск последней не пустой строки в первой колонке
'нужно, что бы данные не были отфильтрованы, иначе последняя строка будет последней строкой в фильтре
'также в последней строке, в первой колонке, не должно быть пустой ячейки.
'конечно, если в этой строке вообще есть данные. Иначе последней строкой будет последняя не пустая ячейка.
FinalRow = Sheet1_WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
'поиск последней не пустой колонки в первой строке
FinalColumn = Sheet1_WS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
'для цикла
Dim i, z As Long
'номер столба исходного
Dim m As Long
'номер столба в который пишем
Dim n As Long
'результат поиска занчения предыдущего периода
Dim SearchPrevRes As Variant
'массив, в котором будут храниться наши данные
'тут можно оптимизировать: не инициализировать каждый раз массив ячеек,
'а сделть глобальными переменными или передавать из процедуры в процедуру
Dim R_data As Variant
'присваиваем массиву диапазон данных на Листе 1
R_data = Sheet1_WS.Range(Sheet1_WS.Cells(1, 1), Sheet1_WS.Cells(FinalRow, FinalColumn))
'создаем два массива для номеров столбов: с которого брать исходник и в который заносить рассчитанное значение
'в массив можно занести любые пары столбов. т.е. если нужно добавить рассчет в этом файле по новому столбу в массив добавляем пару.
ToWrite = Array(8, 10) 'перечень номеров столбов, откуда брать значения, добавлять всегда парами с FromWrite
FromWrite = Array(7, 9) 'перечень номеров столбов, куда писать значения
'скачем по всем столбам, которые нужно перерассчитывать. соответсвенно в файле д.б. столб исходный и пустой столб для записи
'тут можно оптимизировать: не для каждой пары отдельно искать значения, а сразу для всех пар.
'тогда количество циклов будет не по количеству пар, а один.
For z = LBound(ToWrite) To UBound(ToWrite) 'можно обойти один массив т.к. они по количеству всегда одинаковые т.к. должны идти парами
n = ToWrite(z)
m = FromWrite(z)
'для каждой пары столбов рассчитываем значение
For i = 2 To FinalRow 'помчали со второй строки т.к. первая названия полей
If Month(R_data(i, 1)) = 1 Then 'если первый месяц, ничего считать не нужно
R_data(i, n) = R_data(i, m)
Else 'если месяц не первый, вычитаем из значения текущего месяца значение предыдущего
SearchPrevRes = SearchPrevValue(i, m) 'функция SearchPrevRes ищет то что надо, для указанного номера столба
If IsNull(SearchPrevRes) Then 'если нужной строки в файле нет, пишем "нд"
R_data(i, n) = "нд"
Else: R_data(i, n) = R_data(i, m) - SearchPrevRes
End If
End If
Next i
'копируем данные из массива обратно на Лист1
'перед этим можно очистить данные на листе (если есть форматирование или формулы, то лучше Sheet1_WS.Cells.ClearContents)
'Sheet1_WS.Cells.ClearContents
'или
'Sheet1_WS.Cells.Delete
Sheet1_WS.Range(Sheet1_WS.Cells(1, 1), Sheet1_WS.Cells(FinalRow, n)) = R_data
Next z
End Sub
Все тоже самое в xlsm-файле на дропбоксе.
