I would like to convert a single row of text into a table

I have text data in single row for ex as below:

row#1:Identityid:15 Identitydesc:unkown Currentdate:current timeid:020112017.  timeid:020501201. creationdate:27-02-15 06:11:20

row#2:Identityid:16 Identitydesc:unkown Currentdate: Unkown timeid:020112017.  timeid:020501201. creationdate:27-02-15 06:11:20

I would like to convert the above 2 rows data into a table like:
header will be identityid and under this column it should take 15 and in next row 16 simililarly my next Column will ne Identitydesc: and under that unknow in next row and so on...before colon should become columns and post colon data should come under those columns

Thanks in advance
kausalya durgaleAsked:
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.

aikimarkCommented:
Does your data in row 2 actually contain a space here: Currentdate: Unkown?
0
aikimarkCommented:
Does your data actually have two timeid: name/value pairs in each row?
0
kausalya durgaleAuthor Commented:
Hi There- No Space before unknown in Row#2

and you can consider first timeid as fromtimeid and next timeid as Totimeid in both rows
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

aikimarkCommented:
Please confirm:
There is a period character after the time values?
0
kausalya durgaleAuthor Commented:
Yes, there is period character at the end of time values
0
aikimarkCommented:
also, where is the table of values to be placed relative to these rows?
0
kausalya durgaleAuthor Commented:
Identityid       Identitydesc                                      Currentdate      fromtimeid      Totimeid      creationdate
15                          Unknown                                    Current              20112017      20501201      27/2/2015 6:11
16                          Unknown                                      unkown            20112017      20501201      27/2/2015 6:11
0
kausalya durgaleAuthor Commented:
Values after colon should be placed as table values
0
aikimarkCommented:
Please test this:
Sub Q_29076381()
    Dim rngSrc As Range
    Dim rngTgt As Range
    Dim strData As String
    
    Dim dicData As Object
    
    Dim oRE As Object
    Dim oMatches As Object
    Dim oM As Object
    Dim oSM As Object
    Dim lngSM As Long

    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = False
    oRE.Pattern = "(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^$]+)"
    
    Set dicData = CreateObject("scripting.dictionary")
    
    Set rngTgt = Worksheets("Sheet2").Range("A2")
    Set rngSrc = Worksheets("Sheet1").Range("A1")
    strData = rngSrc.Value
    Application.ScreenUpdating = False
    Do Until Len(strData) = 0
        If oRE.test(strData) Then
            Set oMatches = oRE.Execute(strData)
            Set oM = oMatches(0)
                With oM
                    For lngSM = 0 To .submatches.Count - 1 Step 2
                        dicData(.submatches(lngSM)) = .submatches(lngSM + 1)
                    Next
                End With
        End If
        rngTgt.Resize(1, dicData.Count).Value = dicData.items
        Set rngTgt = rngTgt.Offset(1)
        
        Set rngSrc = rngSrc.Offset(1)
        strData = rngSrc.Value
        If Len(strData) = 0 Then
        Else
            dicData.RemoveAll
        End If
    Loop
    Set rngTgt = Worksheets("Sheet2").Range("A1")
    rngTgt.Resize(1, dicData.Count).Value = dicData.keys
    Application.ScreenUpdating = True
End Sub

Open in new window

0
kausalya durgaleAuthor Commented:
Thanks much this works! I have similar data in 24 rows with table values as different. could you please let me know if I have to change any range
0
aikimarkCommented:
As long as the source rows start on Street1!A1 and there is a Sheet2 worksheet, this code should work for any six-pair data like you posted.  It doesn't have to be the same column headings, but it does need to be the same number of columns (name:value pairs) in order to match the regex pattern.
0
aikimarkCommented:
The code (regex pattern) assumes that there will always be six pairs in each row.  Also, assume that the name:value pairs will be in the same order for all rows.
0
kausalya durgaleAuthor Commented:
Thanks, would run this and get back to you in case of any errors!:)
0
kausalya durgaleAuthor Commented:
in case if any of the columns is missing in any one of the row will this code work?
0
aikimarkCommented:
No.  I posted a solution based on the sample data you provided.  It does not assume (or allow for) missing data.
0
kausalya durgaleAuthor Commented:
Hi There- for regex pattern were you have coded for 6 pairs (column) if i have to go on and add few more columns, should i Just change the regex pattern?
0
kausalya durgaleAuthor Commented:
for ex: if my rows have one more col: ater creationdate that is Imid

Identityid:15 Identitydesc:unkown Currentdate:current fromtimeid:020112017.  Totimeid:020501201. creationdate:27-02-15 06:11:20 Imid: 27
Identityid:16 Identitydesc:unkown Currentdate: Unkown fromtimeid:020112017.  Totimeid:020501201. creationdate:27-02-15 06:11:20 Imid:30
0
aikimarkCommented:
If the tags vary, then this approach should work:
Sub Q_29076381()
    Dim rngSrc As Range
    Dim rngTgt As Range
    Dim strData As String
    Dim vAllData As Variant
    Dim vItem As Variant
    Dim lngLoop As Long
    
    Dim dicData As Object
    Dim dicHeader As Object
    
    Dim oRE As Object
    Dim oMatches As Object
    Dim oM As Object
    Dim oSM As Object
    Dim lngSM As Long

    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = True
    
    Set dicData = CreateObject("scripting.dictionary")
    Set dicHeader = CreateObject("scripting.dictionary")
    
    Set rngTgt = Worksheets("Sheet2").Range("A2")
    Set rngSrc = Worksheets("Sheet1").Range("A1")
    
    oRE.Pattern = "([A-Za-z]+):"
    vAllData = Worksheets("Sheet1").Range(rngSrc, rngSrc.End(xlDown)).Value
    For Each vItem In vAllData
        Set oMatches = oRE.Execute(vItem)
        For Each oM In oMatches
            If dicHeader.exists(oM.submatches(0)) Then
                dicHeader(oM.submatches(0)) = dicHeader(oM.submatches(0)) + 1
            Else
                dicHeader(oM.submatches(0)) = 1
            End If
        Next
    Next
    lngLoop = 1
    For Each vItem In dicHeader
        dicHeader(vItem) = lngLoop
        lngLoop = lngLoop + 1
    Next
    
    Erase vAllData
    
'    oRE.Pattern = "(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^ ]+)\W+(\w+): ?([^$]+)"
    oRE.Pattern = "(" & Join(dicHeader.keys, "|") & "):(.+?)(?=" & Join(dicHeader.keys, "|") & "|$)"
    strData = rngSrc.Value
    Application.ScreenUpdating = False
    Do Until Len(strData) = 0
        If oRE.test(strData) Then
            Set oMatches = oRE.Execute(strData)
            For Each oM In oMatches
                With oM
                    'Debug.Print .submatches(0), Trim(.submatches(1))
                    dicData(.submatches(0)) = Trim(.submatches(1))
                End With
            Next
        End If
        ReDim vAllData(1 To dicHeader.Count)
        For Each vItem In dicData
            vAllData(dicHeader(vItem)) = dicData(vItem)
        Next
        rngTgt.Resize(1, dicHeader.Count).Value = vAllData      'dicData.items
        Set rngTgt = rngTgt.Offset(1)
        
        Set rngSrc = rngSrc.Offset(1)
        strData = rngSrc.Value
        If Len(strData) = 0 Then
        Else
            dicData.RemoveAll
        End If
    Loop
    Set rngTgt = Worksheets("Sheet2").Range("A1")
    rngTgt.Resize(1, dicHeader.Count).Value = dicHeader.keys
    Application.ScreenUpdating = True
End Sub

Open in new window

I put your sample data and a row of my own into sheet1
Q_29076381.xlsm
0

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
kausalya durgaleAuthor Commented:
Thank you! I assume this will work if any number of columns gets added in the Source Sheet?
0
aikimarkCommented:
Yes
0
kausalya durgaleAuthor Commented:
Thank you So much!... one more thing can we add a button in a different sheet, upon clicking sheet gets generated?
0
aikimarkCommented:
You are welcome to do what you need to do to launch the code that I provided.  I have answered your question.
0
kausalya durgaleAuthor Commented:
Thanks Much this Helps!
0
kausalya durgaleAuthor Commented:
Thanks much for your help!:):)
0
kausalya durgaleAuthor Commented:
Hi There, I am using below code to send mail automatically from excel. I want to send mail to many recipients in To and CC, where should I modify, below code is working fine to send email to my own id: also this mail goes everyday and the date in the subject line should automatically consider current date of every day.

Sub Mail_Sheet_Outlook_Body()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set rng = Nothing
    Set rng = ActiveSheet.UsedRange
    'You can also use a sheet name
    'Set rng = Sheets("YourSheet").UsedRange

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "kausalya.durgale@accenture.com"
        .CC = ""
        .BCC = ""
        .Subject = "Service Check 12-01-2018,NEED YOUR CONFIRMATION by 01:30 PM IST "
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0
   

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
0
aikimarkCommented:
Please open a new question about multiple recipient email
0
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.