Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для создания сводной таблицы
 
#1
26.05.2021 21:44:26
Здравствуйте! Помогите пожалуйста с макросом для создания сводной таблицы
Подробное описание вопроса в файле
Встроенный в эксель инструмент сводных таблиц не подходит, т.к. загружаемые формы бывают разные и неудобно каждый раз делать новую сводную таблицу
 
 
 
#2
27.05.2021 07:03:39
cargo9,
здравствуйте!
Честно говоря, больше на ТЗ похоже   ;)

Для начала, можно определить последние заполненные строку и столбец, а после найти нужные значения в 1 строке
Код
Sub aaa()
lLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
lLastRow = Cells(Rows.Count, 4).End(xlUp).Row

For y = 1 To lLastCol
    If Cells(1, y) = "выбор" Then
        MsgBox "выбор в столбце: " + CStr(y)
    End If
Next y

For y = 1 To lLastCol
    If Cells(1, y) = "перечисление" Then
        MsgBox "перечисление в столбце: " + CStr(y)
    End If
Next y

For y = 1 To lLastCol
    If Cells(1, y) = "сумма" Then
        MsgBox "сумма в столбце: " + CStr(y)
    End If
Next y

End Sub
Изменено: evgeniygeo - 27.05.2021 07:34:48
 
 
 
#3
27.05.2021 15:17:42
evgeniygeo,
добрый день!
честно говоря, я в программировании чайник...
поэтому дописать макрос до конца на смогу
но если это больше похоже на ТЗ, то могу отправить донат за работу)))
 
 
 
#4
27.05.2021 15:20:37
cargo9,
А что такое
Цитата
отправить донат за работу)))
 
 
 
#5
27.05.2021 15:27:45
Kuzmich, благодарность на человеческом языке) хотя может имелся ввиду пончик)
Изменено: Mershik - 27.05.2021 15:28:21
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#6
27.05.2021 15:29:51
именно благодарность))
 
 
 
#7
27.05.2021 15:30:16
Цитата
благодарность на человеческом языке
Как говорил Жванецкий:
Лучше маленький доллар, чем большое спасибо
 
 
 
#8
27.05.2021 15:30:56
Цитата
Kuzmich написал:
маленький доллар
ну думаю и будет доллар  в валюте по курсу ЦБ)
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#9
27.05.2021 15:34:14
cargo9,
Поскольку
Цитата
Честно говоря, больше на ТЗ похоже   ;)
и вашего решения нет вообще, то
решение с нуля за вас
 
 
 
#10
27.05.2021 15:35:52
Цитата
Mershik написал:
ну думаю и будет доллар  в валюте по курсу ЦБ)
всё верно) только помогите кто-нибудь плиз)
 
 
 
#11
27.05.2021 15:42:26
cargo9,
Цитата
только помогите кто-нибудь плиз
Вот посмотрите пример выполнения макроса
 
 
 
#12
27.05.2021 16:09:32
всё правильно, только я забыл в в описании вопроса одну деталь...
она написана в примечании к ячейке F10 на листе "полученные данные",
там не должно дважды повторяться значение "розовый", и остальных столбцов это тоже касается
 
 
 
#13
27.05.2021 16:40:37
Код
Sub Мануфактура()
    Worksheets("исходные данные").Range("D1:Z1000").Copy Worksheets("полученные данные").Range("D1")
     
    With Worksheets("полученные данные").Sort
        .SortFields.Clear
        
        Dim aXvybor As Variant
        Dim aXperch As Variant
        Dim aXsumma As Variant
        Dim aXempty As Variant
        Dim y As Long
        Dim e As Long
        Dim i As Long
        Dim x As Variant
        
        y = WorksheetFunction.CountIfs(Worksheets("полученные данные").Range("D1:Z1"), "выбор")
        If y > 0 Then
            ReDim aXvybor(1 To y)
            ReDim aXperch(1 To y)
            ReDim aXsumma(1 To y)
            ReDim aXempty(1 To y)
        End If
        
        y = WorksheetFunction.CountIfs(Worksheets("полученные данные").Range("D1:Z1"), "перечисление")
        If y > 0 Then
            ReDim aXperch(1 To y)
        End If
        
        y = WorksheetFunction.CountIfs(Worksheets("полученные данные").Range("D1:Z1"), "сумма")
        If y > 0 Then
            ReDim aXsumma(1 To y)
        End If
        
        y = WorksheetFunction.CountIfs(Worksheets("полученные данные").Range("D1:Z1"), "")
        If y > 0 Then
            ReDim aXempty(1 To y)
        End If
        
        
        Dim cl As Range
        y = 0
        x = 0
        e = 0
        i = 0
        For Each cl In Worksheets("полученные данные").Range("D1:Z1")
            Select Case cl.Value
            Case "выбор"
                .SortFields.Add Key:=Range(Cells(4, cl.Column).Resize(1000 - 4 + 1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                
                y = y + 1
                aXvybor(y) = cl.Column
            Case "перечисление"
                i = i + 1
                aXperch(i) = cl.Column
            Case "сумма"
                x = x + 1
                aXsumma(x) = cl.Column
            Case ""
                e = e + 1
                aXempty(e) = cl.Column
            End Select
        Next
        
        .SetRange Range("D4:Z1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim flag As Boolean
    Dim arr As Variant
    arr = Worksheets("полученные данные").Range("A1:Z1000")
    For y = 4 To UBound(arr, 1)
        If arr(y, 4) <> "" Then
                    
            e = y + 1
            Do
                If e = UBound(arr, 1) Then Exit Do
                flag = True
                For Each x In aXvybor
                    If arr(e, x) <> arr(y, x) Then
                        flag = False
                        Exit For
                    End If
                Next
                If flag Then
                    e = e + 1
                Else
                    e = e - 1
                    Exit Do
                End If
                DoEvents
            Loop
            
            For i = y + 1 To e
                For Each x In aXsumma
                    arr(y, x) = arr(y, x) + arr(i, x)
                Next
                For Each x In aXperch
                    arr(y, x) = arr(y, x) & IIf(arr(y, x) = "", ", ", ", ") & arr(i, x)
                Next
                For x = 1 To UBound(arr, 2)
                    arr(i, x) = Empty
                Next
            Next
            
            For Each x In aXempty
                arr(y, x) = Empty
            Next
        
        
        End If
    Next
    
    Worksheets("полученные данные").Range("A1:Z1000") = arr
    With Worksheets("полученные данные").Sort
        .SortFields.Clear
        
        For Each cl In Worksheets("полученные данные").Range("D1:Z1")
            Select Case cl.Value
            Case "выбор"
                .SortFields.Add Key:=Range(Cells(4, cl.Column).Resize(1000 - 4 + 1).Address(0, 0)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End Select
        Next
        
        .SetRange Range("D4:Z1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub
 
 
 
#14
27.05.2021 17:37:37
МатросНаЗебре,
Огромное спасибо, всё работает!
Напишите в личку, как могу отблагодарить)
 
 
 
Страницы: 1
Наверх