Добрый день, столкнулся с очередной проблемой, есть сводная ведомость, с данными конкретной структуры (количество/дата). Необходимо подсчитать итог по столбцам, но: - если все даты (после "/") равны, то суммируется количество (работает); - если есть расхождения по датам, то необходимо суммировать каждую дату, и тут проблема, если отличная дата одна и не повторятся, то считает правильно, если отличных дат несколько или они повторяются, то получается ерунда. помогите с решением проблемы, заранее спасибо, и да, знаю что опять не угадал с названием темы, приму любое название какое предложите.
Sub TT()
Dim arrIn, arrOut, arrK, lngI&, lngJ&, lngK&, lngS&, Uniq As Object
Set Uniq = CreateObject("Scripting.Dictionary")
lngI = [a2].CurrentRegion.Rows.Count
lngJ = [a2].CurrentRegion.Columns.Count
arrIn = Range(Cells(3, "D"), Cells(lngI, lngJ)).Value2
ReDim arrOut(1 To UBound(arrIn, 1), 1 To UBound(arrIn, 2))
For lngJ = 1 To UBound(arrIn, 2)
For lngI = 1 To UBound(arrIn, 1)
On Error Resume Next
Uniq.Add Split(arrIn(lngI, lngJ), "/")(1), Split(arrIn(lngI, lngJ), "/")(1)
Next lngI
arrK = Uniq.Keys
For lngK = 0 To Uniq.Count - 1
For lngI = 1 To UBound(arrIn, 1)
If Uniq.Item(arrK(lngK)) = Split(arrIn(lngI, lngJ), "/")(1) Then lngS = lngS + Val(Split(arrIn(lngI, lngJ), "/")(0))
Next lngI
arrOut(lngK + 1, lngJ) = lngS & "/" & Uniq.Item(arrK(lngK)): lngS = 0
Next lngK
Uniq.RemoveAll: Erase arrK
Next lngJ
[d7].Resize(UBound(arrOut, 1), UBound(arrOut, 2)) = arrOut
End Sub
Основная идея - сначала по каждому столбцу определяем уникальные элементы после "/" при помощи словаря, потом суммируем по этим элементам все числа до "/" и пишем все это в массив результатов. Потом массив результатов выгружаем на лист от ячейки D7 Код для данных из примера.
Пытливый, спасибо работает, для полного счастья, выгруженный массив по столбцам в одну ячейку загнать отдельным макросом. или при выгрузке проще сцепить?
Инженер не тот, кто все знает, а тот кто знает где найти ответ.
Sub итог_now()
Dim Baza()
'Sheets("Сводная").Activate
lk = Sheets("Сводная").Cells(Rows.Count, 3).End(xlUp).Row
ls = Sheets("Сводная").Cells(2, Columns.Count).End(xlToLeft).Column
Baza = Range(Cells(3, 4), Cells(lk, ls)).Value
Set sd = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Baza, 2)
For j = 1 To UBound(Baza, 1)
If sd.Exists(Baza(j, i)) Then
sd.Item(Baza(j, i)) = sd.Item(Baza(j, i)) + 1
Else
sd.Item(Baza(j, i)) = 1
End If
Next
For Each K In sd.keys
If IsEmpty(K) Then Exit For
If IsEmpty(m) Then
m = sd.Item(K) * Split(K, "/")(0) & Mid(K, 2, 99)
Else
m = m & "; " & sd.Item(K) * Split(K, "/")(0) & Mid(K, 2, 99)
End If
Next
Cells(lk + 10, i + 3) = m
sd.RemoveAll
m = Empty
Next
End Sub
Sub tt()
r0_ = 3
c0_ = 4
nr_ = Cells(Rows.Count, c0_ - 1).End(3).Row - r0_ + 1
nc_ = Cells(r0_ - 1, Columns.Count).End(1).Column - c0_ + 1
ar = Cells(r0_, c0_).Resize(nr_, nc_).Value
ar1 = Cells(r0_ + nr_, c0_).Resize(, nc_).Value
Set slov = CreateObject("Scripting.Dictionary")
With slov
On Error Resume Next
For j = 1 To nc_
For i = 1 To nr_
sp_ = Split(ar(i, j), "/")
.Item(sp_(1)) = .Item(sp_(1)) + Val(sp_(0))
Next i
For Each k_ In .keys
ar1(1, j) = ar1(1, j) & vbLf & .Item(k_) & "/" & k_
Next k_
ar1(1, j) = Mid(ar1(1, j), 2, 999)
.RemoveAll
Next j
On Error GoTo 0
End With
Cells(r0_ + nr_, c0_).Resize(, nc_) = ar1
End Sub
_Boroda_, спс, попробую. Пытливый, спс. всем спс, я отошел, пока остановился на варианте V, надо листинг еще внимательно почитать, может разберусь что к чему.
Инженер не тот, кто все знает, а тот кто знает где найти ответ.
V, может быть я так и не разобрался в коде до конца, нашел еще небольшую ошибку, при создании ведомости ВКПО в графе Носки летн. в итогах к количеству добавляется дополнительная цифра "2", с чем это связано? в остальных такого нет, только в этой графе.