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?
 
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
 
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
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
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
 
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
 
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
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.