Macro Problem

Dear Experts,

I have a macro written by  a member of Experts Exchange which takes the content of one cell and breaks it into columns.  It searches the headings headings listed in one worksheet within the cell and then copies the data to the relevant column.  I have hit a problem due to a change in the column it is searching.

The macro is:
Sub ParseAD_Report()
Dim cel As Range, rg As Range, targ As Range
Dim v As Variant, vHeaders As Variant
Dim s As String
Dim i As Long, j As Long, k As Long, n As Long, nHeaders As Long
Application.ScreenUpdating = False
With Worksheets("Formatted")
    Set rg = .Range("E2")       'First cell with data
    Set rg = .Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp))
End With
With Worksheets("Formatted2")
    Set targ = .Range("A1")     'First header label
    Set targ = .Range(targ, .Cells(1, .Columns.Count).End(xlToLeft))    'All the header labels
    vHeaders = targ.Value
    nHeaders = targ.Columns.Count
    n = .UsedRange.Rows.Count
End With
For Each cel In rg.Cells
    s = cel.Value
    If s <> "" Then
        n = n + 1
        j = 1
        For k = 1 To nHeaders
            If vHeaders(1, k) <> "" Then
                v = Application.Search(vHeaders(1, k), s, 1)
                If Not IsError(v) Then
                    i = v + Len(vHeaders(1, k))
                    j = Application.Search(vbLf, s & vbLf, i)
                    targ.Cells(n, k).Value = Trim(Mid$(s, i, j - i))
                End If
            End If
        Next
    End If
Next
End Sub

Open in new window

It is searching for Account Name: Account Domain: Account Name: Account Domain within the following:

"A user account was unlocked.
Subject:
Security ID:S-1-5-21-4084637156-299436391-3671333128-2841
Account Name:username 1
Account Domain:Domain
Logon ID:0x43A772A9
Target Account:
Security ID:S-1-5-21-4084637156-299436391-3671333128-1412
Account Name:Username 2
Account Domain:Domain"

But the problem is it copies the first username and domain twice instead of moving down the message and picking up the second username.  

I am not sure how to correct this issue.

Any help would be greatly appreciated.

Regards,
Infosec36
===============
Prior related question: http://www.experts-exchange.com/questions/28714620/Formatting-Data-Import.html
Sonia BowditchInformation Security OfficerAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Can you supply a sample workbook?
Sonia BowditchInformation Security OfficerAuthor Commented:
Hello Martin,

I have attached a sample workbook.

Regards.User-Account-Unlocked.xlsm
Martin LissOlder than dirtCommented:
Are there always two Account Name and two Account Domain values in each row of the Formatted sheet?
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Martin LissOlder than dirtCommented:
Try this and let me know if there are any problems.
Sub ParseAD_Report()
Dim lngLastRow As Long
Dim lngNewRow As Long
Dim lngRow As Long
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim strParts() As String
Dim lngPart As Long
Dim intCol As Integer

Set wsSource = Worksheets("Formatted")
Set wsDest = Worksheets("Formatted2")

With wsSource
    lngLastRow = .Range("E1048576").End(xlUp).row
    lngNewRow = wsDest.Range("A1048576").End(xlUp).row
    For lngRow = 2 To lngLastRow
        lngNewRow = lngNewRow + 1
        intCol = 1
        strParts = Split(.Cells(lngRow, "E"), vbLf)
        For lngPart = 0 To UBound(strParts)
            If InStr(1, strParts(lngPart), wsDest.Range("A1")) > 0 Or _
               InStr(1, strParts(lngPart), wsDest.Range("B1")) > 0 Then
                wsDest.Cells(lngNewRow, intCol) = Split(strParts(lngPart), ":")(1)
                intCol = intCol + 1
            End If
        Next
    Next
End With
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
aikimarkCommented:
My gut reaction is that the duplicates are the result of the FormatText()

Please post a copy of the source file that was imported.
Sonia BowditchInformation Security OfficerAuthor Commented:
Perfect.  Thank you.
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015, Experts-Exchange Top Expert Visual Basic Classic 2012 to 2014
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.