Добрый день господа. Есть задача более глобальная, но я запутался в решении правильной записи последовательности дат... Суть вопроса: Есть множество счетов надо привести их к читабельному виду и свести в менее массивную таблицу. Искать последовательности дат в общем списке по ИД клиента. Но есть еще особенность счета могут быть 2 видов. Это тоже надо разделить... Все в файле. Получается 3 условия. ИД - Вид счета - Их последовательность.
Добрый день господа. Есть задача более глобальная, но я запутался в решении правильной записи последовательности дат... Суть вопроса: Есть множество счетов надо привести их к читабельному виду и свести в менее массивную таблицу. Искать последовательности дат в общем списке по ИД клиента. Но есть еще особенность счета могут быть 2 видов. Это тоже надо разделить... Все в файле. Получается 3 условия. ИД - Вид счета - Их последовательность.Timber_Wolf
Немного поясню. Если поможет решению. Все данные ВСЕГДА отсортированы по ИД далее по Виду счета А или Б и третий уровень по дате выставления от старых к новым...
Немного поясню. Если поможет решению. Все данные ВСЕГДА отсортированы по ИД далее по Виду счета А или Б и третий уровень по дате выставления от старых к новым...Timber_Wolf
Можно сводной - единственное не все даты сразу видны (сделал от-до)- но, их можно увидеть либо клацнув два раза на интересующей ячейке, либо раскрыв +
Можно сводной - единственное не все даты сразу видны (сделал от-до)- но, их можно увидеть либо клацнув два раза на интересующей ячейке, либо раскрыв +SLAVICK
SLAVICK, Спасибо но не то =)) Про сводные знаем, работали... =)) Требуется именно обработка макросом. Я же писал это часть (модуль) большого проекта. =))) Данные входят в табличном разрозненном виде, выходят отсортированные и читабельные в табличном текстовом виде. В общем у вас минимум не выполняется условие разрыва последовательных периодов в последней строке. Последовательный период через дефис должен быть, а разрыв между последовательными периодами через запятую =))
SLAVICK, Спасибо но не то =)) Про сводные знаем, работали... =)) Требуется именно обработка макросом. Я же писал это часть (модуль) большого проекта. =))) Данные входят в табличном разрозненном виде, выходят отсортированные и читабельные в табличном текстовом виде. В общем у вас минимум не выполняется условие разрыва последовательных периодов в последней строке. Последовательный период через дефис должен быть, а разрыв между последовательными периодами через запятую =))Timber_Wolf
имеется ввиду не последовательные даты (дни), а последовательные месяцы, так?
Просто с месяцами что-то нереально. Если все ч/з запятую, то так попробуйте
[vba]
Код
Sub ertert() Dim x, y(), i&, s$, Ts$, k& Dim bu As Boolean
x = Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To 4)
For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 3) If Ts <> s Then Ts = s k = k + 1 y(k, 1) = x(i, 1) y(k, 2) = x(i, 2) y(k, 3) = x(i, 3) y(k, 4) = x(i, 4) Else y(k, 2) = y(k, 2) + x(i, 2) y(k, 4) = y(k, 4) & ", " & x(i, 4) End If Next i [k2].Resize(k, 4).Value = y() End Sub
имеется ввиду не последовательные даты (дни), а последовательные месяцы, так?
Просто с месяцами что-то нереально. Если все ч/з запятую, то так попробуйте
[vba]
Код
Sub ertert() Dim x, y(), i&, s$, Ts$, k& Dim bu As Boolean
x = Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To 4)
For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 3) If Ts <> s Then Ts = s k = k + 1 y(k, 1) = x(i, 1) y(k, 2) = x(i, 2) y(k, 3) = x(i, 3) y(k, 4) = x(i, 4) Else y(k, 2) = y(k, 2) + x(i, 2) y(k, 4) = y(k, 4) & ", " & x(i, 4) End If Next i [k2].Resize(k, 4).Value = y() End Sub
nilem, Да там обрабатываются именно последовательность в месяцах. Но просто через запятую не вариант. Приходится обрабатывать по 5-6 лет порой. Это такая портянка на выходе получится в одной ячейке.... Затем и делается что бы были разрывные и не разрывные периоды, при чем поглощались одинаковые и становились одним месяцем.
nilem, Да там обрабатываются именно последовательность в месяцах. Но просто через запятую не вариант. Приходится обрабатывать по 5-6 лет порой. Это такая портянка на выходе получится в одной ячейке.... Затем и делается что бы были разрывные и не разрывные периоды, при чем поглощались одинаковые и становились одним месяцем.Timber_Wolf
nilem, С месяцами реально. =)) Я уже делал. Но код тормозил безбожно и вешал периодически эксель, но на выходе было именно то что нужно. И в силу кочевания с места на место я куда то потерял этот код =((( А теперь блин по памяти не могу восстановить. Да и надеюсь найти ответы работающие более оперативно чем моя прежняя разработка. =((
nilem, С месяцами реально. =)) Я уже делал. Но код тормозил безбожно и вешал периодически эксель, но на выходе было именно то что нужно. И в силу кочевания с места на место я куда то потерял этот код =((( А теперь блин по памяти не могу восстановить. Да и надеюсь найти ответы работающие более оперативно чем моя прежняя разработка. =((Timber_Wolf
Sub ertert() Dim x, y(), i&, s$, Ts$, k& Dim bu As Boolean
x = Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To 4)
For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 3) If Ts <> s Then Ts = s k = k + 1 y(k, 1) = x(i, 1) y(k, 2) = x(i, 2) y(k, 3) = x(i, 3) y(k, 4) = x(i, 4) Else y(k, 2) = y(k, 2) + x(i, 2) y(k, 4) = y(k, 4) & ", " & x(i, 4) End If Next i For i = 1 To k If InStr(y(i, 4), ",") Then y(i, 4) = ConcNum33(y(i, 4)) Else y(i, 4) = Format(y(i, 4), "mmmm yyyy") End If Next i [k2].Resize(k, 4).Value = y() End Sub
[/vba]
и еще функция (положите в тот же модуль)
[vba]
Код
Function ConcNum33(ByVal sRng As String) As String 'если числа в одной ячейке Dim s$, x, i&, bu As Boolean x = Split(sRng & ", 31.12.2100", ", ") If UBound(x) = 0 Then ConcNum33 = x(0): Exit Function For i = 0 To UBound(x) - 1 s = s & ", " & Format(x(i), "mmmm yyyy") Do While DateDiff("m", x(i), x(i + 1), vbMonday, vbUseSystem) < 2 bu = True: i = i + 1 Loop If bu Then s = s & "-" & Format(x(i), "mmmm yyyy"): bu = False Next i ConcNum33 = Mid(s, 3) End Function
[/vba]
Функция будет корректно работать (ну должна, по крайней мере) до 31.12.2100 г. )
Sub ertert() Dim x, y(), i&, s$, Ts$, k& Dim bu As Boolean
x = Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To 4)
For i = 2 To UBound(x) s = x(i, 1) & "~" & x(i, 3) If Ts <> s Then Ts = s k = k + 1 y(k, 1) = x(i, 1) y(k, 2) = x(i, 2) y(k, 3) = x(i, 3) y(k, 4) = x(i, 4) Else y(k, 2) = y(k, 2) + x(i, 2) y(k, 4) = y(k, 4) & ", " & x(i, 4) End If Next i For i = 1 To k If InStr(y(i, 4), ",") Then y(i, 4) = ConcNum33(y(i, 4)) Else y(i, 4) = Format(y(i, 4), "mmmm yyyy") End If Next i [k2].Resize(k, 4).Value = y() End Sub
[/vba]
и еще функция (положите в тот же модуль)
[vba]
Код
Function ConcNum33(ByVal sRng As String) As String 'если числа в одной ячейке Dim s$, x, i&, bu As Boolean x = Split(sRng & ", 31.12.2100", ", ") If UBound(x) = 0 Then ConcNum33 = x(0): Exit Function For i = 0 To UBound(x) - 1 s = s & ", " & Format(x(i), "mmmm yyyy") Do While DateDiff("m", x(i), x(i + 1), vbMonday, vbUseSystem) < 2 bu = True: i = i + 1 Loop If bu Then s = s & "-" & Format(x(i), "mmmm yyyy"): bu = False Next i ConcNum33 = Mid(s, 3) End Function
[/vba]
Функция будет корректно работать (ну должна, по крайней мере) до 31.12.2100 г. )nilem
Яндекс.Деньги 4100159601573
Сообщение отредактировал nilem - Пятница, 16.12.2016, 12:14
короче сейчас макрос выдает отсортированную, консолидированную таблицу при этом в колонке с датами строка из месяцев и годов по возрастанию. Далее думаю над разбором данной строки...
ЗЫЖ для макроса предварительный порядок сортировки "до фонаря"
Начнем по малому...
короче сейчас макрос выдает отсортированную, консолидированную таблицу при этом в колонке с датами строка из месяцев и годов по возрастанию. Далее думаю над разбором данной строки...
ЗЫЖ для макроса предварительный порядок сортировки "до фонаря"dim34rus
Sub d() Dim d As Object, arr(1 To 4), d1 As New Scripting.Dictionary Set d = CreateObject("Scripting.dictionary") m = Range("A2").CurrentRegion.Value Range(Selection, Selection.End(xlDown)).Select For i = 2 To UBound(m) s = m(i, 1) & m(i, 3) If d1.exists(s) Then m1 = d1.Item(s) m1(2) = m1(2) + m(i, 2) dd = CDate(Right(m1(4), 10)) t = DateDiff("m", dd, DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)) Select Case True Case t > 1 m1(4) = m1(4) & "," & m(i, 4) Case Len(m1(4)) < 11 m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) Case Right(m1(4), 11) = "," & dd m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) Case Else m1(4) = Left(m1(4), Len(m1(4)) - 11) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) End Select d1(s) = m1 Else For ii = 1 To 3: arr(ii) = m(i, ii): Next arr(4) = DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) d1(s) = arr End If Next m1 = d1.Items ReDim mf(1 To UBound(m1) + 1, 1 To 4) For i = 0 To UBound(m1) ss = m1(i)(4) For ii = 1 To Len(m1(i)(4)) Step 11 s = Format(Mid(m1(i)(4), ii, 10), "MMMM YYYY") ss = Replace(ss, Mid(m1(i)(4), ii, 10), s) Next mf(i + 1, 1) = m1(i)(1): mf(i + 1, 2) = m1(i)(2): mf(i + 1, 3) = m1(i)(3): mf(i + 1, 4) = ss Next Cells(3, "n").Resize(i, 4) = mf End Sub
[/vba]
У меня так вышло: [vba]
Код
Sub d() Dim d As Object, arr(1 To 4), d1 As New Scripting.Dictionary Set d = CreateObject("Scripting.dictionary") m = Range("A2").CurrentRegion.Value Range(Selection, Selection.End(xlDown)).Select For i = 2 To UBound(m) s = m(i, 1) & m(i, 3) If d1.exists(s) Then m1 = d1.Item(s) m1(2) = m1(2) + m(i, 2) dd = CDate(Right(m1(4), 10)) t = DateDiff("m", dd, DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)) Select Case True Case t > 1 m1(4) = m1(4) & "," & m(i, 4) Case Len(m1(4)) < 11 m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) Case Right(m1(4), 11) = "," & dd m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) Case Else m1(4) = Left(m1(4), Len(m1(4)) - 11) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) End Select d1(s) = m1 Else For ii = 1 To 3: arr(ii) = m(i, ii): Next arr(4) = DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1) d1(s) = arr End If Next m1 = d1.Items ReDim mf(1 To UBound(m1) + 1, 1 To 4) For i = 0 To UBound(m1) ss = m1(i)(4) For ii = 1 To Len(m1(i)(4)) Step 11 s = Format(Mid(m1(i)(4), ii, 10), "MMMM YYYY") ss = Replace(ss, Mid(m1(i)(4), ii, 10), s) Next mf(i + 1, 1) = m1(i)(1): mf(i + 1, 2) = m1(i)(2): mf(i + 1, 3) = m1(i)(3): mf(i + 1, 4) = ss Next Cells(3, "n").Resize(i, 4) = mf End Sub