Посчитать количество повторяющихся записей в массиве или другой вариант решения

[blackeangel]

В общем в экселе есть макрос, который подключается к серверу и при помощи запроса скачивает данные таблицы в массив. Необходимо посчитать количество каждой повторяющейся записи. Записи распологаются в разнобой и простым перебором не получится посчитать.
результирующие кол-ва надо записывать в соседний столбец. Если возможно это делать во время запроса как то, то будет идеально. Если нет, то нужен быстрый способ, то есть не перебор массива, и сделать это в виде отдельной функции, чтоб на входе один массив, на выходе другой.

[Iska]

Какой макрос? Что за сервер? Какой запрос? Что понимать под «каждой повторяющейся записью»?

[blackeangel]

Что понимать под «каждой повторяющейся записью»?

Например,

М
М
М
М
М

На выходе

М
М
М
М
М 5

[Iska]

blackeangel, там, выше, четыре вопроса.

[blackeangel]

Iska,
Макрос таков

Sub KD()
Dim arr1()
Application.ScreenUpdating = False
ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(ncolumn + 1).Insert
Cells(1, ncolumn + 1).Value = "Карточки"
m = ActiveSheet.Cells(Rows.Count, ncolumn).End(xlUp).Row
Set rn = ActiveSheet.Cells(2, ncolumn).Resize(m, 2)
arr2 = rn.Value
Set conn = New ADODB.Connection
conn.ConnectionString = "Provider=*;Password=*;Persist Security Info=True;User ID=User_for_macros_PDM;Initial Catalog=db_pdm_ScanKD;Data Source=RTVS-SQL05" 'Строка подключения
conn.Open
Set rst = New ADODB.Recordset
rst.ActiveConnection = conn
Ask = "SELECT [Oboznach],[Count_page],[ScanFile] FROM [db_pdm_ScanKD].[dbo].[pdm_vwScanKD] Where Not ([Oboznach] Like '%СБ'or [Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2')"
rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic
arr1 = rst.GetRows
conn.Close
arr1 = TransposeDim(arr1)
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If Len(arr2(j, 1)) > 0 Then
If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
arr2(j, 2) = arr1(i, 0)
End If
End If
Next j
Next i
ActiveSheet.Cells(2, ncolumn).Resize(UBound(arr2), UBound(arr2, 2)) = arr2
Application.ScreenUpdating = True
End Sub

[Iska]

Смотрите, Вам нужно использовать запрос с группировкой (GROUP BY) и выражением Count(*) для подсчёта записей. А если диалект позволяет — то можно сократить кучу «[Oboznach] Like '%…'» до нескольких выражений (но это не суть важное). Наподобие:
https://i.imgur.com/q00O1mI.png
У Вас, кстати, в запросе дважды повторяется «ПГ3».

[blackeangel]

Iska,
Как то так?

Sub KD()
Dim arr1()
Application.ScreenUpdating = False
ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(ncolumn + 1).Insert
Cells(1, ncolumn + 1).Value = "Карточки"
m = ActiveSheet.Cells(Rows.Count, ncolumn).End(xlUp).Row
Set rn = ActiveSheet.Cells(2, ncolumn).Resize(m, 2)
arr2 = rn.Value
Set conn = New ADODB.Connection
conn.ConnectionString = "Provider=*;Password=*;Persist Security Info=True;User ID=User_for_macros_PDM;Initial Catalog=db_pdm_ScanKD;Data Source=RTVS-SQL05" 'Строка подключения
conn.Open
Set rst = New ADODB.Recordset
rst.ActiveConnection = conn
Ask = "SELECT [Oboznach],[Count_page], COUNT(*) as КоличествоЗаписей " _
& "FROM [db_pdm_ScanKD].[dbo].[pdm_vwScanKD] " _
& "Where Not ([Oboznach] Like '%СБ'or [Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2') " _
& " GROUP BY [Oboznach],[Count_page]"
rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic
ActiveSheet.Cells(2, ncolumn).copyfromrecordset rst
Application.ScreenUpdating = True
End Sub


Только один вопрос - как сократить кол-во Like?

[Iska]

Как то так? »
Если работает — то так. Но вообще должно быть не WHERE, а HAVING. У меня-то ведь нету этой базы, посему могу рассуждать токмо умозрительно.

Только один вопрос - как сократить кол-во Like? »
Провайдер-то кто, что за база?