Macro similar to Text to Columns

S

shre0047

Board Regular
Joined
Feb 3, 2017
Messages
53
Office Version
  1. 365
Platform
  1. Windows
From a report, the data within one column will have multiple line breaks within the cell which I parsed out via marcro.

Here is an example the layout of the mentioned cell:
Full Text: Here is the full sentence


Description: Here is the full description for support.


Type (1): Color
Type (1) Risk: High


Type (2): Size
Type (2) Risk: Low


Type (3): Volume
Type (3) Risk: High

<tbody>
</tbody>

I have the following macro set up and it works for the happy path
Code: 
Sub splitText()


    Application.ScreenUpdating = False


    'splits Text active cell using ALT+10 char as separator
    Dim splitVals As Variant
    Dim totalVals As Long
    Dim i As Integer
    
    'Add columns to avoid overwriting data
    Columns("D:O").Select
    Selection.Insert Shift:=xlToRight
    Range("C2").Select
 
    For i = 1 To 1000
      splitVals = Split(ActiveCell.Value, Chr(10))
      totalVals = UBound(splitVals)
      Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
      ActiveCell.Offset(1, 0).Activate
    Next i
    
    'Delete blank columns
    Columns("E").EntireColumn.Delete
    Columns("F").EntireColumn.Delete
    Columns("H").EntireColumn.Delete
    Columns("J").EntireColumn.Delete
    
    Columns("D:K").ColumnWidth = 20
    
    'Add Column Headers
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Full Text"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Type (1)"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Type (1) Risk"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Type (2)"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Type (2) Risk"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Type (3)"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Type (3) Risk"
    
    'Remove unnecessary wording in each cell
    Columns("D").Replace What:="Full Text: ", Replacement:=""
    Columns("E").Replace What:="Description: ", Replacement:=""
    Columns("F").Replace What:="Type (1): ", Replacement:=""
    Columns("G").Replace What:="Type (1) Risk: ", Replacement:=""
    Columns("H").Replace What:="Type (2): ", Replacement:=""
    Columns("I").Replace What:="Type (2) Risk: ", Replacement:=""
    Columns("J").Replace What:="Type (1): ", Replacement:=""
    Columns("K").Replace What:="Type (1) Risk: ", Replacement:=""
    
    Application.ScreenUpdating = True
 
    End Sub


What I need help with are the two different scenarios:
1 - One row will have 3 types listed out, and the following row will have 2 types listed out. Is there a way to make an iteration to make it separate?
Full Text: Here is the full sentence


Description: Here is the full description for support.


Type (1): Color
Type (1) Risk: High


Type (2): Size
Type (2) Risk: Low


Type (3): Volume
Type (3) Risk: High
Full Text: Here is the full sentence


Description: Here is the full description for support.


Type (1): Color
Type (1) Risk: High


Type (2): Size
Type (2) Risk: Low


<tbody>
</tbody>


2 - If a cell has incorrect line breaks
Full Text: Here is the full sentence



Description: Here is the full description for support.



Type (1): Color
Type (1) Risk: High


Type (2): Size
Type (2) Risk: Low



Type (3): Volume
Type (3) Risk: High

<tbody>
</tbody>
 
Sort by date Sort by votes
Ok, how about
Code: 
Sub suggestedmacro()
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False

      .TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
         Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
         :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
         1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
   End With
End Sub
 
Upvote 0

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Thank you for your help as it works as I wanted!

Code: 
Sub splitText()

    Application.ScreenUpdating = False
    
    'Add columns to avoid overwriting data
    Columns("D:J").Select
    Selection.Insert Shift:=xlToRight
    Range("C2").Select
    
    'Run TexttoColumn
    With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False


      .TexttoColumns Destination:=Range("C2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
    End With
 
    'Delete Req Full Text column
    Columns("C").EntireColumn.Delete
    
    Columns("C:I").ColumnWidth = 20
    
    'Add Column Headers
       Dim rng As Range
    Dim i As Long


    'Set the range in column A you want to loop through
    Set rng = Range("C2:I2")
    For Each cell In rng
         If Left(cell.Value, 23) = "Requirement Description" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Req Description"
        End If


        If Left(cell.Value, 19) = "Compliance Area (1)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (1)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (1) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (1) Risk"
        End If
        
        If Left(cell.Value, 19) = "Compliance Area (2)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (2)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (2) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (2) Risk"
        End If
        
        If Left(cell.Value, 19) = "Compliance Area (3)" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (3)"
        End If
        
        If Left(cell.Value, 24) = "Compliance Area (3) Risk" Then
            'write to adjacent cell
            cell.Offset(-1, 0).Value = "Compliance Area (3) Risk"
        End If
    Next
    
    
    Application.ScreenUpdating = True
 
    End Sub

I also added the macro to find the phrases within the first entry (row2) of the file and provide the header. Is there a way to do something along the lines of (pseudocode):
If Left(cell.Value, 23) = "Requirement Description"
Then Replace What:="Requirement Description: ", Replacement:="" (Replace for the entire column)
cell.Offset(-1, 0).Value = "Req Description"
End If
 
Last edited:
Upvote 0
How about
Code: 
Sub splitText()
   Dim Ary As Variant
   Dim i As Long
   Dim Fnd As Range
   Dim j As Long
   Application.ScreenUpdating = False
   
   'Add columns to avoid overwriting data
   Columns("D:J").Insert Shift:=xlToRight
   
   'Run TexttoColumn
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace Chr(13), "", xlPart, , , , False, False
   
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, "|"
   End With

   'Delete Req Full Text column
   Columns("C").EntireColumn.Delete
   
   Columns("C:I").ColumnWidth = 20
    
   'Add Column Headers
   Ary = Array("Requirement Description", "Compliance Area (1) Risk", "Compliance Area (1)", "Compliance Area (2) Risk", "Compliance Area (2)", "Compliance Area (3) Risk""Compliance Area (3)")
   For i = 0 To UBound(Ary)
      Set Fnd = Range("B2")
      For j = 1 To Application.CountIf(Range("C2:J2"), Ary(i) & "*")
         Set Fnd = Range("B2:J2").Find(Ary(i), Fnd, , xlPart, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.EntireColumn.Replace Ary(i) & ": ", "", xlPart, , False, , False, False
            Fnd.Offset(-1).Value = Ary(i)
         End If
      Next j
   Next i
End Sub
 
Upvote 0
For some reason, the text for a few cells are appearing as the following:
Requirement Description: The following requirement is related to the ability of the application to archive data using the standard relational database archiving process. Data should be able to be archived into Optim without error or
issue.


Compliance Area (1):

<tbody>
</tbody>

Am i able to follow the same code you listed to eliminate the line break within the 'Requirement Description' section?
 
Upvote 0
About the only I can think of is to do something like
Code: 
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(13), "", xlPart, , , , False, False
      .Replace Chr(10), "|", xlPart, , , , False, False
      [COLOR=#0000ff].Replace "|issue", "issue", xlPart, , , , False, False
      .Replace "|the", "the", xlPart, , , , False, False[/COLOR]
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, "|"
   End With
and create other similar lines for all oddities.
 
Upvote 0
Another option is
Code: 
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      .Replace Chr(13), "", xlPart, , , , False, False
      .Replace Chr(10), "|", xlPart, , , , False, False
      .Replace "|Req", Chr(10) & "Req", xlPart, , , , False, False
      .Replace "|Comp", Chr(10) & "Comp", xlPart, , , , False, False
      .Replace "|", "", xlPart, , , , False, False
      .TextToColumns Range("C2"), xlDelimited, xlDoubleQuote, True, False, False, False, False, True, Chr(10)
   End With
which should hopefully deal with all oddities.
 
Upvote 0
I believe this did everything I am looking for. Thank you so much for your help!
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Help with Vba Code
Replies
3
Views
157
Coyotex3
C
R
  • Solved
VBA Concatenate Issue
Replies
2
Views
322
Roballistic
R
K
  • Question
Conditional Formating - Dynamic "not between"
Replies
3
Views
254
dreid1011
dreid1011
S
  • Question
Replace different text/strings in multiple files in one folder
Replies
1
Views
248
Peter_SSs
Peter_SSs
T
  • Question
Workbook not visible by VBA
Replies
5
Views
169
Artik
Artik

Forum statistics

Threads
1,214,819
Messages
6,121,746
Members
449,050
Latest member
excelknuckles

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top