Страницы: 1
RSS
Макрос расчета количества значений из данных таблицы
 
Добрый день, форумчане.
Обращаюсь к вам за помощью, ни как не могу понять как написать макрос для следующей задачки.
Есть таблица с исходными данными по подразделениями в разных городах и есть в шапке заголовки активностей (Спуск 1, Спуск 2 и т.д). Подразделения и города дублируются по несколько строк, так как каждая строка это определенный человек. И необходимо подсчитать в скольких Спусках участвовало определенное подразделение из конкретного города. Сколько участвовало сотрудников не важно. Приложил файл с примером, как есть сейчас исходник и как должно получиться.
 
Доброе время суток
В принципе, можно обойтись и Power Query с Power Pivot.
 
Андрей VG, спасибо за вариант, но он не подходит. Почему именно макрос, на оригинале будет кнопка, после нажатия, макрос создает новую книгу и вносит в нее таблицу.
 
Цитата
nor написал:
он не подходит
Я не настаиваю. :)  Вполне возможно предложенный вариант решения пригодится кому-нибудь другому. Собственно, для этого и делал.
 

nor,

Почему у вас есть этот результат для "Ставрополь" ?

Город УРОиК1 УРОиК2 УРОиК3
Ставрополь     2     0     2

, если в таблице есть что-то другое ?

Подразделение Город Спуск1 Спуск2 Спуск3
УРОиК1 Ставрополь     1     1
УРОиК2 Ставрополь
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
УРОиК3 Ставрополь     1
...
Должно быть вероятно (скорее всего ?) так:

Город УРОиК1 УРОиК2 УРОиК3
Ставрополь     1     0     4
...
Не понимаю этих ваших "УРО(и)КОВ" ..... : ( ... ??? ... : (

Изменено: ocet p - 02.02.2020 00:34:50
 
ocet p,
Нет не 4, а 2. Видно, что подразделение УРОиК1 участвовал в Спуске 1 и Спуске 3 (итого в 2-х спусках),  УРОиК3 участвовал в Спуске 1 и Спуске 2 (итого в 2-х спусках). Суть в том, что не важно сколько строчек с одним и тем же подразделением из одного города, а в том, чтобы показать в скольких спусках участвовало каждое  подразделение из Ставрополя и других городов.  
 
Напишите пожалуйста, как это будет выглядеть (как это "будет суммированным") в следующем списке (картинка):
 
ocet p,
УРОиК1 - будет 3, так как есть данные в каждом спуске. УРОиК2 и УРОиК3 - также будет 3, так как есть данные в каждом спуске.
Изменено: nor - 02.02.2020 10:22:24
 

Пожалуйста проверьте это, будет ли у вас работать или нет ?

У меня, что-то не хотело сотрудничать/работать с вашей кирилицей (названия городов и названия листов - они не хотели сортировать правильно и взаимо узнавать) - надо мне было всё изменить на латиницу - у вас, наоборот замените на кириллицу это: "List1", "Kolichestvo", "Gorod", "UROiK1", "UROiK2", "UROiK3", "Itogo". Код, написанный в "разделах", чтобы вам было легче вносить в него исправления, если бы "что-то случилось".

Код
Option Explicit

Sub abc_xyz()
    Const datasht = "List1"
    Const rsltcell = "G1" 'Tut budet resul'tat raboty makrosa
    
    Dim i&, idx&, j&, k&, dict, itm, ky, tbl
    '--------------------------------------------------------------------------
    With ThisWorkbook.Sheets(datasht)
        tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
    idx = UBound(tbl, 1)
    For i = 1 To idx
        If Trim(tbl(i, 3)) <> "" Then tbl(i, 3) = 1 Else tbl(i, 3) = 0
        If Trim(tbl(i, 4)) <> "" Then tbl(i, 4) = 1 Else tbl(i, 4) = 0
        If Trim(tbl(i, 5)) <> "" Then tbl(i, 5) = 1 Else tbl(i, 5) = 0
    Next
    '--------------------------------------------------------------------------
    For i = 1 To idx - 1
        For j = i + 1 To idx
            If tbl(i, 2) & ";" & tbl(i, 1) > tbl(j, 2) & ";" & tbl(j, 1) Then
                For k = 1 To 5
                    ky = tbl(j, k)
                    tbl(j, k) = tbl(i, k)
                    tbl(i, k) = ky
                Next
            End If
        Next
    Next
    '--------------------------------------------------------------------------
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To idx
        ky = tbl(i, 2) & ";" & tbl(i, 1)
        If Not dict.Exists(ky) Then dict(ky) = 1
    Next
    k = dict.Count: dict.RemoveAll: Set dict = Nothing
    '--------------------------------------------------------------------------
    dict = Empty: ReDim dict(1 To k, 1 To 4): k = 1
    dict(1, 1) = tbl(1, 2) & ";" & tbl(1, 1)
    For j = 2 To 4
        dict(1, j) = tbl(1, j + 1)
    Next
    For i = 2 To idx
        ky = tbl(i - 1, 2) & ";" & tbl(i - 1, 1)
        itm = tbl(i, 2) & ";" & tbl(i, 1)
        If itm <> ky Then
            k = k + 1
            dict(k, 1) = itm
            For j = 2 To 4
                dict(k, j) = tbl(i, j + 1)
            Next
        Else
            For j = 2 To 4
                If dict(k, j) = 0 And tbl(i, j + 1) = 1 Then dict(k, j) = 1
            Next
        End If
    Next
    '--------------------------------------------------------------------------
    tbl = Empty: j = 0: ReDim tbl(1 To k, 1 To 4)
    For i = 1 To k Step 3
        j = j + 1
        tbl(j, 1) = Split(dict(i, 1), ";", -1, 1)(0)                 'Gorod
        tbl(j, 2) = dict(i, 2) + dict(i, 3) + dict(i, 4)             'UROiK1
        tbl(j, 3) = dict(i + 1, 2) + dict(i + 1, 3) + dict(i + 1, 4) 'UROiK2
        tbl(j, 4) = dict(i + 2, 2) + dict(i + 2, 3) + dict(i + 2, 4) 'UROiK3
    Next
    dict = Empty
    '--------------------------------------------------------------------------
    With ThisWorkbook.Sheets(datasht)
        With .Range(rsltcell)
            If .MergeCells Then .MergeArea.UnMerge
            .Value = "Kolichestvo"
            .Offset(1, 0).Resize(1, 4).Value = Array("Gorod", "UROiK1", "UROiK2", "UROiK3")
            .Offset(2, 0).Resize(j, 4).Value = tbl: tbl = Empty
            .Offset(j + 2, 0).Value = "Itogo"
            .Offset(j + 2, 1).Resize(1, 3).FormulaR1C1 = "=SUM(R[-" & j & "]C:R[-1]C)"
            .Resize(1, 4).Merge (True)
        End With
    End With
End Sub
 
ocet p, огромное спасибо за помощь.
Протестировал, в последнем цикле появляется ошибка о переполнении диапозона.
Вот на этом шаге, так как переменная i доходит до полдней терции (22), а к ней ещё + 1 и получается переполнение.
Код
tbl(j, 3) = dict(i + 1, 2) + dict(i + 1, 3) + dict(i + 1, 4) 'UROiK2

У меня получился макрос другой формации, с вложенными циклами. Может и "топорный" получился, но работает.
Код
Sub test()
    Dim shData As Worksheet
    Dim NewWB As Workbook
    Dim iCountDate As Integer
    Dim iLasrColSvod As Integer
    Dim iLasrColData As Integer
    Dim lLastRowData As Long
    Dim i As Integer
    Dim x As Integer
    Dim z As Integer
    Dim iLocat As Integer
    Dim iDeport As Integer
    Dim arrData()
    
    
    
    Set shData = ThisWorkbook.Worksheets("Лист1")
    iLasrColData = shData.Cells(1, Columns.Count).End(xlToLeft).Column
    lLastRowData = shData.Cells(Rows.Count, 1).End(xlUp).Row
    x = 1
        
    ReDim arrData(1 To 10, 1 To 5)
    arrData(1, 1) = "Количество  " & Date
    arrData(2, 1) = "Подразделение"
    arrData(3, 1) = "Нижний Новгород"
    arrData(4, 1) = "Екатеринбург"
    arrData(5, 1) = "Ставрополь"
    arrData(6, 1) = "Омск"
    arrData(7, 1) = "Воронеж"
    arrData(8, 1) = "Волгоград"
    arrData(9, 1) = "Самара"
    arrData(10, 1) = "Итого"
    arrData(2, 2) = "УРОиК1"
    arrData(2, 3) = "УРОиК2"
    arrData(2, 4) = "УРОиК3"
    
       For x = 3 To iLasrColData
            arrData(3, 5) = ""
            arrData(4, 5) = ""
            arrData(5, 5) = ""
            arrData(6, 5) = ""
            arrData(7, 5) = ""
            arrData(8, 5) = ""
            arrData(9, 5) = ""
            For z = 3 To lLastRowData
                If shData.Cells(z, x) <> "" Then
                    For iDeport = 1 To UBound(arrData, 2)
                        If shData.Cells(z, 1) = arrData(2, iDeport) Then
                            For iLocat = 1 To UBound(arrData)
                                If shData.Cells(z, 2) = arrData(iLocat, 1) Then
                                    If arrData(iLocat, 5) = 1 Then
                                        Exit For
                                    Else
                                        arrData(iLocat, iDeport) = arrData(iLocat, iDeport) + 1
                                        arrData(iLocat, 5) = 1
                                    End If
                                 End If
                             Next iLocat
                        End If
                    Next iDeport
                End If
            Next z
       Next x
            arrData(3, 5) = ""
            arrData(4, 5) = ""
            arrData(5, 5) = ""
            arrData(6, 5) = ""
            arrData(7, 5) = ""
            arrData(8, 5) = ""
            arrData(9, 5) = ""
            arrData(10, 2) = "=SUM(R[-7]C:R[-1]C)"
            arrData(10, 3) = "=SUM(R[-7]C:R[-1]C)"
            arrData(10, 4) = "=SUM(R[-7]C:R[-1]C)"

Set NewWB = Workbooks.Add

NewWB.Worksheets(1).Range("A1").Resize(UBound(arrData), UBound(arrData, 2) - 1) = arrData

With NewWB.Worksheets(1)
    For i = 2 To 4
        For x = 3 To 9
            If .Cells(x, i) = "" Then .Cells(x, i) = 0
        Next x
    Next i
    
    .Range("A1").CurrentRegion.Borders.LineStyle = 1
    .Rows(1).Font.Bold = True
    .Rows(2).Font.Bold = True
    .Rows(10).Font.Bold = True
    .Range("A1:D1").Merge
    .Range("A1").Interior.Color = RGB(198, 224, 180)
    .Columns("A:D").EntireColumn.AutoFit
End With

End Sub
Изменено: nor - 03.02.2020 21:01:24
 
Надо чтобы таблица начиналась с "A1", а как есть у вас ?

tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Код
tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Страницы: 1
Наверх