Excel Loop through list,transpose and create a matrix based on cell content

Question

I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:

| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359     | skj    | 487   |y| 2985789   |

The above data in my file would originally look like this in column A:

KEY 4759839
asljhk
35049

sklahksdjf
KEY 359
skj
487
y
2985789

Considerations:

Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells

I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:

Sub kTest()
    Dim a, w(), i As Long, j As Long, c As Integer
    a = Range([a1], [a500000].End(xlUp))
    ReDim w(1 To UBound(a, 1), 1 To 6)
    j = 1
    For i = 1 To UBound(a, 1)
        c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
        If c = 6 Then j = j + 1
    Next i
    [c1].Resize(j, 6) = w
End Sub

I would greatly appreciate any help you can give me!

assylias · Answer 1 · 2012-05-10T15:11:52.430

2

This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.

Sub kTest()
    Dim originalData As Variant
    Dim result As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim countKeys As Long
    Dim countColumns As Long
    Dim maxColumns As Long

    originalData = Range([a1], [a500000].End(xlUp))

    countKeys = 0
    maxColumns = 0

    'Calculate the number of lines and columns that will be required
    For i = LBound(originalData, 1) To UBound(originalData, 1)
        If Left(originalData(i, 1), 3) = "KEY" Then
            countKeys = countKeys + 1
            maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
            countColumns = 1
        Else
            countColumns = countColumns + 1
        End If
    Next i

    'Create the resulting array
    ReDim result(1 To countKeys, 1 To maxColumns) As Variant

    j = 0
    k = 1
    For i = LBound(originalData, 1) To UBound(originalData, 1)
        If Left(originalData(i, 1), 3) = "KEY" Then
            j = j + 1
            k = 1
        Else
            k = k + 1
        End If
        result(j, k) = originalData(i, 1)
    Next i

    With ActiveSheet
        .Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
    End With

End Sub

edited May 10 '12 at 15:11

answered May 10 '12 at 15:06

assylias

321,522
82
660
783

How did you generate the test data? Would you mind testing my method on your test data to see it runs at a decent speed? – Dan May 10 '12 at 15:18
See my comment to your answer. I just copied the sample data a number of times to get to 500k rows. – assylias May 10 '12 at 15:21
When I tried this on my data is broke on this line ` result(j, k) = originalData(i, 1)` – tehaaron May 10 '12 at 15:23
@tehaaron what do you mean broke? – assylias May 10 '12 at 15:24
It might be a memory issue as this is using a lot of memory. One solution would be to do it in chunks. – assylias May 10 '12 at 15:25
@assylias Subscript out of Range – tehaaron May 10 '12 at 15:27
@tehaaron Not sure why without seeing your data - could happen if the first line of your file in not a KEYxxx – assylias May 10 '12 at 15:29
@assylias the very first value is and should always be "KEY " actually. – tehaaron May 10 '12 at 15:31
Are you interested in trying to get it to work or are you happy with the other solution? I can have another look if you want. – assylias May 10 '12 at 15:40
If you want to spend more time on it I would be happy to run any updates on my file and let you know if they work. Of course if it turns out to run faster I will use it! :) – tehaaron May 10 '12 at 15:46
let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/11116/discussion-between-assylias-and-tehaaron) – assylias May 10 '12 at 15:47

Dan · Accepted Answer · 2012-05-10T15:08:25.783

1

Tested and works:

    Sub test()
    Row = 0
    col = 1

    'Find the last not empty cell by selecting the bottom cell and moving up
    Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is

    'loop through the data
    For i = 1 To Max
        'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
        If (Left(Range("A" & i).Value, 3) = "KEY") Then
             Row = Row + 1
             col = 1
        End If

        Cells(Row, col).Value = Range("A" & i).Value
        If (i > Row) Then
            Range("A" & i).Value = ""
        End If
        col = col + 1

    Next i
End Sub

edited May 10 '12 at 15:08

answered May 10 '12 at 15:01

Dan

45,079
17
88
157

It's fixed now. Tested and runs correctly even if the KEY values are not spaced constantly – Dan May 10 '12 at 15:09
For your optional requirement try this in the above code: If (Left(Range("A" & i).Value, 3) = "KEY") Then Cells(Row + 1, col) = "END" Row = Row + 1 col = 1 End If – Dan May 10 '12 at 15:15
Doing this over 500k records will take several minutes (actually around 7 minutes on my machine). – assylias May 10 '12 at 15:21
This worked perfectly the very first time although it takes quite awhile (that is not a very big deal). I will try your option bit now as well. Thanks!! – tehaaron May 10 '12 at 15:25
If the other method runs in a second compared to 7 minutes then I highly recommend trying to get @assylias's code to work for you! – Dan May 10 '12 at 15:29
@Dan Haha - if he only needs it once, and needs to spend more than 7 minutes on my solution to get it to work, then yours is better! – assylias May 10 '12 at 15:30
Also turn screen updating off for this code, that should speed it up. – Dan May 10 '12 at 15:33
I will actually be running it on a regular basis. Possibly daily but there are a million other things outside of Excel that I could be doing for that 7min if need be :) – tehaaron May 10 '12 at 15:34
@assylias Sure but it could be useful for others for the future – Dan May 10 '12 at 15:35
It looks like it was a typo and we got a happy ending ;-) – assylias May 10 '12 at 16:17

Excel Loop through list,transpose and create a matrix based on cell content

2 Answers2