Статистика_VBA
Собирает количество значений и выводит их в формате СЧЕТЕСЛИ и %user_2065311
vbscript
a year ago
6.7 kB
8
Indexable
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] ```
Editor is loading...