Прошу помочь с подсчетом повторяющихся значений в столбце С (Наименование товара). Т.е. необходимо понять сколько раз закупался каждый товар. Для примера взял сокращенный вариант таблицы. На самом деле таблица огромная, ассортимент незнакомый, хочу увидеть ТОП-5 самых закупаемых товаров.
Sub Art()
Dim x, y
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each x In Range("C4", Cells(Rows.Count, "C").End(xlUp)).Value2
For Each y In Split(x, ";")
y = Split(Trim(y), , 3)(2)
.Item(y) = .Item(y) + 1
Next
Next
Worksheets.Add , ActiveSheet
Range("A1").Resize(.Count).Value = WorksheetFunction.Transpose(.keys)
Range("B1").Resize(.Count).Value = WorksheetFunction.Transpose(.items)
End With
End Sub
Потом отсортируйте (можно записать команду макрорекордером и добавить в код)
Возможно, следует удалить текст в скобках в конце названия, чтобы такие названия считались за одно
Александр написал: а сводной не подойдет? названия заковыристые - один и тот же продукт мб отличатся в написании?
Может и подойдет, научите как:) У меня уже была мысль - может посчитать сколько каждое слово встречается в списке? Ну например - monitor - 2 раза, the - 15 раз, headset - 6 раз и т.д. А потом отфильтровать по ключевым словам в названии...
Подскажите, а как этот код к моей исходной таблице применить? На Примере понятно, вы всё прописали, а какие параметры надо заменить, чтобы этот код к другой аналогичной таблице применился?
Artee1986, эта ошибка не связана с размером таблицы. Она возникает, если описание товара содержит менее 3 слов, т.е. не начинается с "1 pc " или "n pcs ". Возможно, в описании товара содержится символ ";". Макрос в такой модификации остановится и выделит ячейку, на которой происходит ошибка. Соберите файл из таких ячеек и выложите - посмотрим, как лучше сделать.
Код
Sub Art()
Dim x, y, i&
On Error GoTo 1
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each x In Range("C4", Cells(Rows.Count, "C").End(xlUp)).Value2
i = i + 1
For Each y In Split(x, ";")
y = Split(WorksheetFunction.Trim(y), , 3)(2)
.Item(y) = .Item(y) + 1
Next
Next
Worksheets.Add , ActiveSheet
Range("A1").Resize(.Count).Value = WorksheetFunction.Transpose(.keys)
Range("B1").Resize(.Count).Value = WorksheetFunction.Transpose(.items)
End With
Exit Sub
1 Cells(i + 3, "C").Select
MsgBox "y: " & y, vbCritical, "На этой ячейке ошибка"
End Sub
Artee1986, усовершенствовал распознавание количества товара. Все варианты учесть не удалось, но бОльшая часть распознается.
Код
Sub Art()
Dim x, y, re As Object, i&, s$, n&, v()
Set re = CreateObject("vbscript.regexp")
re.ignorecase = True
re.Pattern = " ?-? ?(\d{1,4})( |" & vbTab & ")?(pc|piece|qty)s?\.?"
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
v = Range("C4", Cells(Rows.Count, "C").End(xlUp)).Value2
ReDim d&(1 To UBound(v) * 10, 1 To 2)
For Each x In v
For Each y In Split(x, ";")
s = WorksheetFunction.Trim(y)
If Len(s) Then
With re.Execute(s)
If .Count Then
n = .Item(0).submatches(0)
s = Trim$(re.Replace(s, ""))
Else: n = 1
End If
End With
If .exists(s) Then i = .Item(s) Else i = .Count + 1: .Item(s) = i
d(i, 1) = d(i, 1) + 1
d(i, 2) = d(i, 2) + n
End If
Next
Next
Worksheets.Add , ActiveSheet
Range("A1:C1").Value = Split("Наименование|Число закупок|Кол-во (оценочно!)", "|")
Range("A2").Resize(.Count).Value = WorksheetFunction.Transpose(.keys)
Range("B2:C2").Resize(.Count).Value = d
Columns(1).ColumnWidth = 90
Columns("B:C").AutoFit
End With
End Sub
Переключение раскладок не помогло, дописал сам ручками в VBA, но тоже не читается (скриншот прилагаю). Да ладно, не суть важно, главное, что цифры на свои места стали и понятно что они значат. Спасибо за помощь!