Copy data from one cell into single cells

Hello Experts,

I have a macro kindly written by byundt which searches for certain data and copies it to another worksheet.  For some reason the macro will not copy the data from the last part of the data from the cell.

I have attached an example of the raw data and the macro I use to extract the relevant data.

I hope you can help.

Thanks,
Infosec36
Data.xls
Sonia BowditchInformation Security OfficerAsked:
Who is Participating?
 
krishnakrkcConnect With a Mentor Commented:
Hi

Try this

Sub kTest()
    
    Dim ka, k(), i As Long, H, m As Long
    Dim dic As Object, x, y, j As Long
    
    ka = Worksheets("Raw Data").Range("a1").CurrentRegion.Value2
    
    H = Worksheets("Format").Range("a1").CurrentRegion.Rows(1).Value2
    
    ReDim k(1 To UBound(ka, 1), 1 To UBound(H, 2))
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = 1 To UBound(H, 2)
        dic.Item(Trim$(H(1, i))) = i
    Next
    
    For i = 1 To UBound(ka, 1)
        x = Split(ka(i, 1), vbLf)
        For m = 0 To UBound(x)
            If InStr(1, x(m), ":") Then
                y = Split(x(m), ":")
                If dic.exists(Trim$(y(0)) & ":") Then
                    k(i, dic.Item(Trim$(y(0)) & ":")) = y(1)
                End If
            End If
        Next
    Next
            
    Worksheets("Format").Range("a2").Resize(UBound(k, 1), dic.Count) = k
    
End Sub

Open in new window


Kris
0
 
Sonia BowditchInformation Security OfficerAuthor Commented:
Works perfectly, thank you.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.