Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Конкатенация и суммирование ячеек по циклу - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Конкатенация и суммирование ячеек по циклу (Макросы/Sub)
Конкатенация и суммирование ячеек по циклу
Яесмь Дата: Вторник, 13.02.2018, 17:11 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день, прошу прощения за обращение. Необходима помощь с макросом VBA. Возникла проблема следующего вида, есть данные, они заполнены всегда в 4 столбцах, количество строк неизвестно, расстояние между заполненными диапозонами всегда 1, общее количество строк по каждому диапозону не более 5. По приложенному файлу понятнее. Нужно чтобы данные в ячейках объединялись и суммировались на другой странице. Показал с помощью функций эксель. Как только колонка становится 4, то происходит шаг на первый столбец со смещением строки на определенное значение, чтобы суммировались и объединялись следующие данные. Как это сделать без ограничения по колонкам представляю, но прошу подсказать, как это сделать с переходом. Прилагаю файл. заранее благодарю за любую помощь, простите, если не понятно пояснил, буду благодарен и за подсказки, просто почему-то завис и запутался с циклами, т.к. совсем недавно начал работать с vba.
К сообщению приложен файл: 9251001.xlsx(14Kb)


Сообщение отредактировал Яесмь - Вторник, 13.02.2018, 17:14
 
Ответить
СообщениеДобрый день, прошу прощения за обращение. Необходима помощь с макросом VBA. Возникла проблема следующего вида, есть данные, они заполнены всегда в 4 столбцах, количество строк неизвестно, расстояние между заполненными диапозонами всегда 1, общее количество строк по каждому диапозону не более 5. По приложенному файлу понятнее. Нужно чтобы данные в ячейках объединялись и суммировались на другой странице. Показал с помощью функций эксель. Как только колонка становится 4, то происходит шаг на первый столбец со смещением строки на определенное значение, чтобы суммировались и объединялись следующие данные. Как это сделать без ограничения по колонкам представляю, но прошу подсказать, как это сделать с переходом. Прилагаю файл. заранее благодарю за любую помощь, простите, если не понятно пояснил, буду благодарен и за подсказки, просто почему-то завис и запутался с циклами, т.к. совсем недавно начал работать с vba.

Автор - Яесмь
Дата добавления - 13.02.2018 в 17:11
krosav4ig Дата: Вторник, 13.02.2018, 20:34 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1558
Репутация: 650 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте
Как-то так
[vba]
Код
Sub sdf()
    Dim Dic As Object
    Dim sh As Worksheet
    Dim r As Range, w As Range, c As Range
    Dim arr() As Variant, arr1 As Variant
    Dim i, j, k, l, m, n, o
    
    Set Dic = CreateObject("scripting.dictionary")
    For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas
        With w.Offset(-1, -1).Resize(1, 1)
            n = Abs(Mid(.Value, InStrRev(.Value, "(")))
        End With
        For Each c In w.Offset(, -1)
            Dic(n & "_" & c) = c.Offset(, 1)
        Next
    Next
    With Sheets("Result(было)")
        m = .UsedRange.Columns.Count
        n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count
        Set r = .[A1].CurrentRegion
        ReDim arr(1 To n * m, 1 To 6)
        For i = 1 To n
            For j = 1 To m
                o = (i - 1) * m + j
                If Not IsEmpty(r(1, j)) Then
                    For k = 1 To 3
                       arr(o, k) = r(k, j)
                    Next
                    l = 0
                    For k = 4 To r.Rows.Count
                        l = l + Dic(arr(o, 2) & "_" & r(k, j))
                    Next
                    If l Then arr(o, 5) = l
                    s = ""
                    On Error Resume Next
                    With r.Columns(j)
                        arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23)
                        If IsArray(arr1) Then
                            s = Join(Application.Transpose(arr1), "_")
                        ElseIf Not IsEmpty(arr1) Then
                            s = arr1
                        End If
                        Erase arr1
                    End With
                    arr(o, 6) = s
                End If
            Next
            Set r = r.End(xlDown).End(xlDown).CurrentRegion
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With Sheets("+++++").UsedRange
        Intersect(.Offset(1), .Cells).Clear
        .Cells(4, 1).Resize(o, 6).Value = arr
    End With
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
    Set Dic = Nothing
    Set r = Nothing
    Set w = Nothing
    Set c = Nothing
    Erase arr
End Sub
[/vba]
К сообщению приложен файл: 9251001.xlsm(29Kb)


(_)Õvõ(_)

Сообщение отредактировал krosav4ig - Вторник, 13.02.2018, 20:34
 
Ответить
СообщениеЗдравствуйте
Как-то так
[vba]
Код
Sub sdf()
    Dim Dic As Object
    Dim sh As Worksheet
    Dim r As Range, w As Range, c As Range
    Dim arr() As Variant, arr1 As Variant
    Dim i, j, k, l, m, n, o
    
    Set Dic = CreateObject("scripting.dictionary")
    For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas
        With w.Offset(-1, -1).Resize(1, 1)
            n = Abs(Mid(.Value, InStrRev(.Value, "(")))
        End With
        For Each c In w.Offset(, -1)
            Dic(n & "_" & c) = c.Offset(, 1)
        Next
    Next
    With Sheets("Result(было)")
        m = .UsedRange.Columns.Count
        n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count
        Set r = .[A1].CurrentRegion
        ReDim arr(1 To n * m, 1 To 6)
        For i = 1 To n
            For j = 1 To m
                o = (i - 1) * m + j
                If Not IsEmpty(r(1, j)) Then
                    For k = 1 To 3
                       arr(o, k) = r(k, j)
                    Next
                    l = 0
                    For k = 4 To r.Rows.Count
                        l = l + Dic(arr(o, 2) & "_" & r(k, j))
                    Next
                    If l Then arr(o, 5) = l
                    s = ""
                    On Error Resume Next
                    With r.Columns(j)
                        arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23)
                        If IsArray(arr1) Then
                            s = Join(Application.Transpose(arr1), "_")
                        ElseIf Not IsEmpty(arr1) Then
                            s = arr1
                        End If
                        Erase arr1
                    End With
                    arr(o, 6) = s
                End If
            Next
            Set r = r.End(xlDown).End(xlDown).CurrentRegion
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With Sheets("+++++").UsedRange
        Intersect(.Offset(1), .Cells).Clear
        .Cells(4, 1).Resize(o, 6).Value = arr
    End With
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
    Set Dic = Nothing
    Set r = Nothing
    Set w = Nothing
    Set c = Nothing
    Erase arr
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 13.02.2018 в 20:34
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Конкатенация и суммирование ячеек по циклу (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!