Разложить столбец на строки

[autostavrroute]

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

Не могу закачать файл с примером - выложил ссылку.
https://yadi.sk/i/HjYwy_DQMGiNWg

[autostavrroute]

Подскажите не получается через штатную форму сайта загрузить файл xls и другие, что можно исправить?

[Aleksandr H.]

Я акк новый создавал ((

[autostavrroute]

Ума хватило только формулу накрутить. Будет обсчитывать долговасто при большой базе, но зато работает.
https://yadi.sk/i/8FdW-OfwJEMiEQ

[Aleksandr H.]

мсье знает толк в извращениях (с)

не до конца понял, что именно нужно, но код, внешне, делает то самое что на листе2

Sub GoBitchFaster()
    Dim ws As Worksheet
    Dim dic As Object
    Dim maxCol As Integer
    Dim maxRow As Integer
    Dim clm As Integer
    Dim rw As Integer
    Dim rwOut As Integer
    Dim rightPart As String
    Dim leftPart As String
    Set ws = ActiveSheet
    Set dic = CreateObject("Scripting.Dictionary")
    maxCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For clm = ws.[j1].Column To maxCol
        If Not dic.Exists(ws.Cells(1, clm).Value) Then
            dic.Add Trim(ws.Cells(1, clm).Value), clm
        End If
    Next clm
    maxRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    rw = 3
    Do While rw <= maxRow
        If ws.Cells(rw, "A").Value = "[POI]" Then rwOut = rw: rw = rw + 1
        If InStr(Trim(ws.Cells(rw, "A").Value), "=") Then
            rightPart = Trim(Split(ws.Cells(rw, "A"), "=")(1))
            leftPart = Split(ws.Cells(rw, "A"), "=")(0) & "="
            If leftPart = "Data0=" Then leftPart = leftPart & "("
            If dic.Exists(Trim(leftPart)) Then
                ws.Cells(rwOut, dic(leftPart)).Value = rightPart
            End If
        End If
        rw = rw + 1
    Loop
    Set ws = Nothing
End Sub

[autostavrroute]

Спасибо за утилизацию извращений:
Немного подправил

Sub GoBitchFaster()
    Dim ws As Worksheet
    Dim dic As Object
    Dim maxCol As Integer
    Dim maxRow As Integer
    Dim clm As Integer
    Dim rw As Integer
    Dim rwOut As Integer
    Dim rightPart As String
    Dim leftPart As String
    Set ws = ActiveSheet
    Set dic = CreateObject("Scripting.Dictionary")
    maxCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For clm = ws.[j1].Column To maxCol
        If Not dic.Exists(ws.Cells(1, clm).Value) Then
            dic.Add Trim(ws.Cells(1, clm).Value), clm
        End If
    Next clm
    maxRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    rw = 3
    Do While rw <= maxRow

        If ws.Cells(rw, "A").Value = "[POI]" Or ws.Cells(rw, "A").Value = "[POLYGON]" Then rwOut = rw: rw = rw + 1
        If InStr(Trim(ws.Cells(rw, "A").Value), "=") Then
            rightPart = Trim(Split(ws.Cells(rw, "A"), "=")(1))
            leftPart = Split(ws.Cells(rw, "A"), "=")(0) & "="
            If leftPart = "Data0=" Then leftPart = leftPart & "("
            If dic.Exists(Trim(leftPart)) Then
                ws.Cells(rwOut, dic(leftPart)).Value = rightPart
            End If
        End If
        rw = rw + 1
    Loop
    Set ws = Nothing
End Sub

Вопрос неработоспособности стоит в том что обрабатывает примерно 32000 строк - потом выдает ошибку "Переполнение (ошибка 6)"

[Aleksandr H.]

Сообщение от autostavrroute

обрабатывает примерно 32000 строк

Я бы даже сказал 32.767 последняя строка. Да?

[autostavrroute]

Сообщение от Aleksandr H.

Я бы даже сказал 32.767 последняя строка. Да?

Скорее всего, есть что и как скорректировать?

[Aleksandr H.]

Используйте более "вместительный" тип для переменных хранящих номера строк