Как сгруппировать текстовые данные?

[Dima_com]

Добрый день!
Бьюсь как рыба об лед а нормального решения пока нет.
Есть данные в таблице где уникальные ключи расположены в столбик мне необходимо перенести их в заглавную строчку и сохранить соответствующие им данные.
Попробовал самописный макрос(vbs script): на 17 тыс запесей 10 минут для меня это не приемлемо.

PHP код:

Dim mylt_name: Set mylt_name= CreateObject("Scripting.Dictionary") 'словарь с названиями полей и их координатами
mylt_name.Add "Чип","C"
mylt_name.Add "Деил","D"
mylt_name.Add "Гайка","E"
mylt_name.Add "Рокки","F"

j=2
Do While Not (objApp.Range("A"&j)="")
If mylt_name.Exists(objApp.Range("A"&j).Value) Then 
 
objApp.Range(mylt_name(objApp.Range("A"&j).Value)&j) = objApp.Range("C"&j).Value
objApp.Range("C"&j).Value = ""
Else
End if
j=j+1
Loop 


Попробовал через сводную таблицу но там не отображается текст в ячейках данных.
Прощу о помощи более опытных товарищей.

Заранее спасибо за помощь всем кто отзовется!

[Hugo121]

Ну конечно перебирать 17 000 ячеек не может быть быстро, тут никакой словарь не поможет.
Ещё массивы нужны.

vbs - это принципиально? Тогда давайте весь скрипт, чтоб потестить, но не писать

Писать код пока не пойму как - т.е. что есть и что надо. Да и домой пора...
Но алгоритм такой - всё в массив, циклом загоняем в словарь ключ "15:00|Чип" и Item "говорит" и т.д.
Далее создаём массив под результат (или берём готовое с листа) и циклом в цикле заполняем из словаря - ключи берём из массива.

Или иначе - циклом по результату в один словарь кладём все времена и их позиции, в другой чипов/дейлов с позициями.
Затем циклом по массиву-источнику сразу раскладываем по местам на основе ключей (позицию берём из словарей).

[IgorGO]

17 тыс. строк - 20 сек.

Sub TransPP()
  Dim r1 As Long, r2 As Long, c As Long, cnt As Long, t As Double
  cnt = 1: r1 = 2: r2 = 1: c = 1: t = Timer
  Application.ScreenUpdating = False
  Cells(r2, c) = Cells(r1, 1): Cells(r2 + 1, c) = Cells(r1, 3):  Cells(2, 3).ClearContents
  r1 = 3
  Do
    If WorksheetFunction.CountIf(Cells(1, 1).Resize(1, cnt), Cells(r1, 1)) = 0 _
      Then cnt = cnt + 1: c = cnt: r2 = 1: Cells(r2, c) = Cells(r1, 1): r2 = r2 + 1 _
      Else c = WorksheetFunction.Match(Cells(r1, 1), [1:1], 0): r2 = Cells(r1, c).End(xlUp).Row + 1
    Cells(r2, c) = Cells(r1, 3):  Rows(r1).Cells.ClearContents
    r1 = r1 + 1
  Loop Until Cells(r1, 1) = ""
  Application.ScreenUpdating = True
  MsgBox Timer - t
End Sub

[Hugo121]

Я думаю макросом можно в 5 сек. уложиться. На моей машине, не быстрой...

[Hugo121]

Вообще хотелось бы видеть реальные исходные данные - т.к. с этим временем сплошной геморой - 3 раза преобразовываю, плюс ещё нужно форматировать результат (если в чистое поле выгружаем).
Попробуйте на 17000 строк (делал под расположение точно как в примере!):

Option Explicit

Sub tt()
    Dim a(), i&, t$, ti&, ci&, d As Date, s$, k, arr
    Dim tDic As Object, cDic As Object, mDic As Object
    Dim tm!: tm = Timer

    Set tDic = CreateObject("Scripting.Dictionary"): tDic.comparemode = 1
    Set cDic = CreateObject("Scripting.Dictionary"): cDic.comparemode = 1
    Set mDic = CreateObject("Scripting.Dictionary"): mDic.comparemode = 1

    a = [a3].CurrentRegion.Value
    
    ti = 1: ci = 1
    For i = 1 To UBound(a)

        t = CDate(a(i, 1)) & "|" & a(i, 2)
        If Not mDic.exists(t) Then
            mDic.Item(t) = a(i, 3)
        Else
            If mDic.Item(t) <> a(i, 3) Then MsgBox "Конфликт у " & t & "!!!", vbCritical
        End If

        d = a(i, 1): s = CStr(d)
        If Not tDic.exists(s) Then
            ti = ti + 1: tDic.Item(s) = ti
        End If

        t = CStr(a(i, 2))
        If Not cDic.exists(t) Then
            ci = ci + 1: cDic.Item(t) = ci
        End If
        
    Next

    ReDim a(1 To tDic.Count + 1, 1 To cDic.Count + 1)

    i = 1: For Each k In tDic.keys
        i = i + 1: a(i, 1) = CDate(k)
    Next
    i = 1: For Each k In cDic.keys
        i = i + 1: a(1, i) = k
    Next
    For Each k In mDic.keys
        arr = Split(k, "|")
        a(tDic.Item(arr(0)), cDic.Item(arr(1))) = mDic.Item(k)
    Next

    With [m2].Resize(UBound(a), UBound(a, 2))
        .Columns(1).NumberFormat = "m/d/yyyy h:mm"
        .Value = a
    End With

    MsgBox "Выполнено за " & Round(Timer - tm, 3) & " s"

End Sub

P.S. Да - нужны только только исходные данные, итоговая даблица генерится из них. И есть предупреждение при конфликте данных - если вдруг будет повтор по времени и "дейлу", но с другим действием.

[Dima_com]

Как раз вам ответ писал. 1 секунду тестирую ваш код

[Hugo121]

Секунду тестируете или за секунду отрабатывает?
Полчаса тестируете уже...

[Dima_com]

Да пытаюсь разобраться в ошибке Run-time error 9: subscript out of range
Вот приблизительно реальный пример данных.
Ошибка массивов пока сложно у вас в коде понимаю каких

[Hugo121]

Мой косяк, исправил код выше...
Ошибка была в строке

ci = ci + 1: cDic.Item(t) = ci

не ту переменную в словарь заносил, последствия копипаста...
Ещё подправил формат, т.к. реальные данные другие, на "m/d/yyyy h:mm"
И для этого файла корректнее будет

a = [a1].CurrentRegion.Value

хотя и с A3 работает также.
Отрабатывает за 2 секунды. Если прокликивать конфликты (включив их) - уложился в 16

[Dima_com]

Это просто супер. Очень большое спасибо единственное не могу понять в синтаксисе определения переменных:

Dim a(),

и

i&, t$,

Тоесть что значит долар и амперпсандр в этом контексте?