Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сложить последовательно элементы текстовой переменной
 
#1
28.05.2019 11:40:28
Доброго времени суток, уважаемые форумчане. Подскажите, пожалуйста, как, если такое возможно, сложить последовательно текстовые элементы 1|2|3|4|5 и 11|12|13|14|15 так, чтобы в итоге элемент был равен 12|14|16|18|20. Как видно 1-я цифра 1-го элемента складывается с 1-ой цифрой 2-го элемента и т.д. В прилагаемом примере это нужно для возможности изменения значения элемента словаря:
Код
        Set dicData = CreateObject("Scripting.Dictionary"): dicData.CompareMode = 1
        x = Range("A1:F4").Value

            For i = 1 To UBound(x)
               Key = x(i, 1) 'ключ словаря
               Item = x(i, 2) & "|" & x(i, 3) & "|" & x(i, 4) & "|" & x(i, 5) & "|" & x(i, 6) 'элемент словаря
                dicData.Item(Key) = dicData.Item(Key) + Item
            Next i
            
            On Error Resume Next
            ReDim Arr_data(1 To dicData.Count, 1 To 7)
                For Each k In dicData.keys
                    Data = Split(dicData.Items()(j), "|")
                    j = j + 1
                    Arr_data(j, 1) = j 
                    Arr_data(j, 2) = k 
                    Arr_data(j, 3) = CDbl(Data(0))
                    Arr_data(j, 4) = CDbl(Data(1))
                    Arr_data(j, 5) = CDbl(Data(2))
                    Arr_data(j, 6) = CDbl(Data(3))
                    Arr_data(j, 7) = CDbl(Data(4))
                Next k
                    Range("A12").Resize(UBound(Arr_data, 1), 7).Value = Arr_data 'выгрузка результата
Сейчас такое сложение выполнятся неверно, получается "1|2|3|4|511|12|13|14|15", что разумеется приводит к неверному значению  при формировании массива для выгрузки. Можно ли сделать так как мне нужно? Заранее спасибо всем откликнувшимся
 
 
 
#2
28.05.2019 12:12:40
Код
Private Sub CommandButton1_Click()
        Set dicData = CreateObject("Scripting.Dictionary"): dicData.CompareMode = 1
        x = Range("A1:F4").Value

            For i = 1 To UBound(x)
               Key = x(i, 1) 'ключ словаря
               Item = x(i, 2) & "|" & x(i, 3) & "|" & x(i, 4) & "|" & x(i, 5) & "|" & x(i, 6) 'элемент словаря
                dicData.Item(Key) = dicData.Item(Key) & "||" & Item
            Next i
            
            On Error Resume Next
            ReDim Arr_data(1 To dicData.Count, 1 To 7)
                For Each k In dicData.keys
                    ar = Split(dicData(k), "||") ' получаеи все строки кейса
                    j = j + 1
                    Arr_data(j, 1) = j 'нумерация
                    Arr_data(j, 2) = k '
                    For r = 1 To UBound(ar)
                        Data = Split(ar(r), "|")
                        For i = 0 To UBound(Data)
                            Arr_data(j, i + 3) = Arr_data(j, i + 3) + CDbl(Data(i))
                        Next i
                    Next r
                Next k
            Range("A12").Resize(UBound(Arr_data, 1), 7).Value = Arr_data 'выгрузка результата
End Sub
 
 
 
#3
28.05.2019 12:15:30
Словарь массивов
Код
Private Sub CommandButton1_Click()
Dim x(), iArr(), newArr(), I&, J&
x = Range("A1:F4").Value
On Error Resume Next
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(x)
        .Add x(I, 1), Application.Index(x, I, 0)
        If Err <> 0 Then
            iArr = .Item(x(I, 1))
            For J = 2 To UBound(.Item(x(I, 1))): iArr(J) = iArr(J) + x(I, J): Next
            .Item(x(I, 1)) = iArr
            Err.Clear
        End If
    Next
    ReDim newArr(1 To .Count, 0 To UBound(x, 2))
    I = Empty
    For Each iKey In .Keys
        iArr = .Item(iKey)
        I = I + 1: newArr(I, 0) = I
        For J = 1 To UBound(iArr): newArr(I, J) = iArr(J): Next
    Next
End With
Range("A16").Resize(UBound(newArr), UBound(newArr, 2) + 1) = newArr 'выгрузка результата
End Sub
Изменено: Sanja - 28.05.2019 13:29:38
Согласие есть продукт при полном непротивлении сторон
 
 
 
#4
28.05.2019 12:24:58
Александр Моторин, Sanja огромное спасибо за Ваши варианты, считают правильно, Буду прикручивать к реальному файлу и изучать способы показанные Вами. Еще раз спасибо
 
 
 
Страницы: 1
Наверх