Статистика_VBA

Sub CreateStatistics()

    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim values() As Variant
    Dim counts() As Long
    Dim i As Integer, j As Integer
    Dim sheetName As String
    Dim statSheet As Worksheet
    Dim rowCount As Integer
    Dim totalCells As Long
    Dim currentColumn As Integer

    ReDim values(1 To 1) As Variant
    ReDim counts(1 To 1) As Long
    currentColumn = 1

    ' Создание нового листа для статистики
    sheetName = "Статистика"
    i = 1
    While SheetExists(sheetName)
        sheetName = "Статистика" & i
        i = i + 1
    Wend

    Set statSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    statSheet.Name = sheetName

    ' Пользователь выбирает диапазоны данных
    Do
        Set rng = Application.InputBox("Выберите диапазон данных:", Type:=8)
        If rng Is Nothing Then Exit Sub

        ' Сбор статистики по диапазону
        totalCells = 0
        ReDim values(1 To 1)
        ReDim counts(1 To 1)
        For Each cell In rng
            If Not IsEmpty(cell.Value) Then
                j = 0
                For i = 1 To UBound(values)
                    If values(i) = cell.Value Then
                        counts(i) = counts(i) + 1
                        j = i
                        Exit For
                    End If
                Next i

                If j = 0 Then
                    If UBound(values) = 1 And IsEmpty(values(1)) Then
                        values(1) = cell.Value
                        counts(1) = 1
                    Else
                        ReDim Preserve values(1 To UBound(values) + 1)
                        ReDim Preserve counts(1 To UBound(counts) + 1)
                        values(UBound(values)) = cell.Value
                        counts(UBound(counts)) = 1
                    End If
                End If
                totalCells = totalCells + 1
            End If
        Next cell

        ' Заполнение листа статистикой
        rowCount = 1
        For i = 1 To UBound(values)
            statSheet.Cells(rowCount, currentColumn).Value = values(i)
            statSheet.Cells(rowCount, currentColumn + 1).Value = counts(i)
            If totalCells > 0 Then
                statSheet.Cells(rowCount, currentColumn + 2).Value = counts(i) / totalCells * 100
            Else
                statSheet.Cells(rowCount, currentColumn + 2).Value = 0
            End If
            rowCount = rowCount + 1
        Next i

        currentColumn = currentColumn + 4 ' Переход к следующему блоку столбцов

        If MsgBox("Выбрать еще один диапазон?", vbYesNo) = vbNo Then Exit Do
    Loop

    ' Сортировка данных в каждом блоке
For i = 1 To currentColumn Step 4
    If i + 2 <= currentColumn Then
        rowCount = statSheet.Cells(statSheet.Rows.Count, i).End(xlUp).Row
        statSheet.Range(statSheet.Cells(1, i), statSheet.Cells(rowCount, i + 2)).Sort Key1:=statSheet.Cells(1, i + 1), Order1:=xlDescending, Header:=xlGuess
    End If
Next i

MsgBox "Статистика создана на листе '" & sheetName & "'"
End Sub

Function SheetExists(sheetName As String) As Boolean
Dim sheet As Worksheet
On Error Resume Next
Set sheet = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not sheet Is Nothing
End Function

=================================== ================================ 



более старый вариант все в одну колонку складывает
```

[Sub CreateStatistics()

    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim values() As Variant
    Dim counts() As Long
    Dim i As Integer
    Dim sheetName As String
    Dim statSheet As Worksheet
    Dim rowCount As Integer
    Dim totalCells As Long
    Dim valueIndex As Integer
    Dim found As Boolean

    ReDim values(1 To 1) As Variant
    ReDim counts(1 To 1) As Long
    totalCells = 0

    ' Пользователь выбирает диапазоны данных
    Do
        Set rng = Application.InputBox("Выберите диапазон данных:", Type:=8)
        If rng Is Nothing Then Exit Sub

        ' Сбор статистики по диапазону
        For Each cell In rng
            If Not IsEmpty(cell.Value) Then
                found = False
                For i = 1 To UBound(values)
                    If values(i) = cell.Value Then
                        counts(i) = counts(i) + 1
                        found = True
                        Exit For
                    End If
                Next i

                If Not found Then
                    If UBound(values) = 1 And IsEmpty(values(1)) Then
                        values(1) = cell.Value
                        counts(1) = 1
                    Else
                        ReDim Preserve values(1 To UBound(values) + 1)
                        ReDim Preserve counts(1 To UBound(counts) + 1)
                        values(UBound(values)) = cell.Value
                        counts(UBound(counts)) = 1
                    End If
                End If
                totalCells = totalCells + 1
            End If
        Next cell

        If MsgBox("Выбрать еще один диапазон?", vbYesNo) = vbNo Then Exit Do
    Loop

    ' Создание нового листа для статистики
    sheetName = "Статистика"
    i = 1
    While SheetExists(sheetName)
        sheetName = "Статистика" & i
        i = i + 1
    Wend

    Set statSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    statSheet.Name = sheetName

    ' Заполнение листа статистикой
    rowCount = 1

    For i = 1 To UBound(values)
        statSheet.Cells(rowCount, 1).Value = values(i)
        statSheet.Cells(rowCount, 2).Value = counts(i)
        If totalCells > 0 Then
            statSheet.Cells(rowCount, 3).Value = counts(i) / totalCells * 100
        Else
            statSheet.Cells(rowCount, 3).Value = 0
        End If
        rowCount = rowCount + 1
    Next i

    ' Сортировка данных
    statSheet.Range("A1:C" & rowCount - 1).Sort Key1:=statSheet.Range("B1"), Order1:=xlDescending, Header:=xlGuess

    MsgBox "Статистика создана на листе '" & sheetName & "'"

End Sub

Function SheetExists(sheetName As String) As Boolean
    Dim sheet As Worksheet
    On Error Resume Next

Set sheet = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not sheet Is Nothing

End Function]
```