How to get perform this operation only in the current Cell of a ta

[vrk1]

Hi,

I have a macro that splits the cells that have Hard returns inside all the
tables in my current document into separate rows. Someone sent me this
macro below to perform this function.

If I need this macro to operate only on the current Cell where my cursor
is and not all the tables in my document, how should I modify this?


Macro Below:

Sub RowSplit()

For x = 1 To ThisDocument.Tables.Count

For Each r In ThisDocument.Tables(x).Rows

If InStr(1, r, Chr(13)) < Len(r.Cells(1).Range) Then

rowsArray = Split(r.Cells(1).Range, Chr(13))
nSubRowCount = UBound(rowsArray)

If nSubRowCount > 1 Then
r.Select

For i = nSubRowCount To 1 Step -1
If Len(Replace(rowsArray(i), Chr(7), "")) > 0
Then
Selection.InsertRowsBelow
ThisDocument.Tables(x).Cell(r.Index + 1,
1).Range = rowsArray(i)
r.Select
End If
Next
Selection.Range = rowsArray(0)
End If

End If

Next
Next

End Sub

 

[Julian]

That code seems to assume there is only once cell per row, if your table
really does have just once cell per row this should work...

Remove the two outer loops (tables and rows) and just use "Set r =
selection.row"

If however your table has more than one cell per row

the line

If InStr(1, r, Chr(13)) < Len(r.Cells(1).Range) Then

should probably become (so you only test the cell the you are in)

if InStr(1,selection.cells(1), Chr(13)) < Len(r.Cells(1).Range) then

NB I didn't attend too closely to the rest of the detail... not very good at
reading other people's code... styles & preferences differ! If you have
further problems please ask again...

HTH

Julian

 

[Jean-Guy Marcil]

Hi,

I have a macro that splits the cells that have Hard returns inside all the
tables in my current document into separate rows. Someone sent me this
macro below to perform this function.

If I need this macro to operate only on the current Cell where my cursor
is and not all the tables in my document, how should I modify this?


Macro Below:

Sub RowSplit()

For x = 1 To ThisDocument.Tables.Count

For Each r In ThisDocument.Tables(x).Rows

If InStr(1, r, Chr(13)) < Len(r.Cells(1).Range) Then

rowsArray = Split(r.Cells(1).Range, Chr(13))
nSubRowCount = UBound(rowsArray)

If nSubRowCount > 1 Then
r.Select

For i = nSubRowCount To 1 Step -1
If Len(Replace(rowsArray(i), Chr(7), "")) > 0
Then
Selection.InsertRowsBelow
ThisDocument.Tables(x).Cell(r.Index + 1,
1).Range = rowsArray(i)
r.Select
End If
Next
Selection.Range = rowsArray(0)
End If

End If

Next
Next

End Sub

You mean like this:

Sub RowSplit()

Dim i As Long
Dim r As Long
Dim rowsArray() As String
Dim nSubRowCount As Long
Dim rgeCell As Range

Set rgeCell = Selection.Range

With Selection.Cells(1)
If InStr(1, r, Chr(13)) < Len(.Range) Then
rowsArray = Split(.Range, Chr(13))
nSubRowCount = UBound(rowsArray)
If nSubRowCount > 1 Then
Selection.Rows(1).Select
r = Selection.Rows(1).Index
For i = 0 To nSubRowCount
If Len(Replace(rowsArray(i), Chr(7), "")) > 0 Then
r = r + 1
Selection.InsertRowsBelow
Selection.Tables(1).Cell(r, 1).Range = rowsArray(i)
Selection.Tables(1).Rows(r).Select
End If
Next
End If
End If
End With

rgeCell.Select

End Sub

 

[Julian]

Sorry - forgot the second replacement in the line it should of course have
become

if InStr(1,selection.cells(1), Chr(13)) < Len(selection.cells(1).Range) then

 

[vrk1]

Thank you Julian and Jean for your response.

My requirement slightly changed and due to this I have changed the macro in
line with your suggestions as below:

Here is my requirement:
I need to highlight a particular row in a Table and run a macro. The macro
looks for all hard return characters in the 1st cell and splits the table
wherever there is a Hard return. For instance, if the 1st cell has 4 hard
returns, then the macro should create 4 rows and place the text in those 4
rows as separate cells. The macro below is able to do that. However, I have
outline numbering (Styles) associated with these 4 lines and they are getting
messed up. I want the macro to be able to preserve the initial Outline
numbering scheme that I originally had.

Does anyone know how to achieve this please?

Here is my Macro:
Sub SplitSelectedRow()

If Selection.Type = 4 Then '4 represents the type Row

rowsArray = Split(Selection.Cells(1).Range, Chr(13))

nSubRowCount = UBound(rowsArray)

If nSubRowCount > 1 Then
Selection.Cells(1).Range = rowsArray(0)
For i = nSubRowCount To 1 Step -1
If Len(Replace(rowsArray(i), Chr(7), "")) > 0 Then
Selection.InsertRowsBelow
Selection.Range = rowsArray(i)
Selection.MoveUp
End If
Next

End If
End If

End Sub

 

[Jean-Guy Marcil]

Thank you Julian and Jean for your response.

My requirement slightly changed and due to this I have changed the macro in
line with your suggestions as below:

Here is my requirement:
I need to highlight a particular row in a Table and run a macro. The macro
looks for all hard return characters in the 1st cell and splits the table
wherever there is a Hard return. For instance, if the 1st cell has 4 hard
returns, then the macro should create 4 rows and place the text in those 4
rows as separate cells. The macro below is able to do that. However, I have
outline numbering (Styles) associated with these 4 lines and they are getting
messed up. I want the macro to be able to preserve the initial Outline
numbering scheme that I originally had.

Does anyone know how to achieve this please?

Here is my Macro:
Sub SplitSelectedRow()

If Selection.Type = 4 Then '4 represents the type Row

rowsArray = Split(Selection.Cells(1).Range, Chr(13))

nSubRowCount = UBound(rowsArray)

If nSubRowCount > 1 Then
Selection.Cells(1).Range = rowsArray(0)
For i = nSubRowCount To 1 Step -1
If Len(Replace(rowsArray(i), Chr(7), "")) > 0 Then
Selection.InsertRowsBelow
Selection.Range = rowsArray(i)
Selection.MoveUp
End If
Next

End If
End If

End Sub

Like this? (By the way, 5 is the Row type, not 4)
Also, I notice that you use code without declaring variables... Not a good
idea, especially when you get into larger projects that require debugging.


Sub SplitSelectedRow()

Dim rgePara As Range
Dim nSubRowCount As Long
Dim i As Long

If Selection.Type = 5 Then
nSubRowCount = Selection.Cells(1).Range.Paragraphs.Count
If nSubRowCount > 1 Then
Set rgePara = Selection.Cells(1).Range
For i = 1 To nSubRowCount
With Selection
.InsertRowsBelow
With .Cells(1).Range
.Text = rgePara.Paragraphs(i).Range.Text
.Characters(.Characters.Count - 1).Delete
.Paragraphs(1).Format = rgePara.Paragraphs(i).Format
End With
End With
Next
End If
End If

End Sub

 

[vrk1]

Wow! You are amazing. thank you very much!

Like this? (By the way, 5 is the Row type, not 4)
Also, I notice that you use code without declaring variables... Not a good
idea, especially when you get into larger projects that require debugging.


Sub SplitSelectedRow()

Dim rgePara As Range
Dim nSubRowCount As Long
Dim i As Long

If Selection.Type = 5 Then
nSubRowCount = Selection.Cells(1).Range.Paragraphs.Count
If nSubRowCount > 1 Then
Set rgePara = Selection.Cells(1).Range
For i = 1 To nSubRowCount
With Selection
.InsertRowsBelow
With .Cells(1).Range
.Text = rgePara.Paragraphs(i).Range.Text
.Characters(.Characters.Count - 1).Delete
.Paragraphs(1).Format = rgePara.Paragraphs(i).Format
End With
End With
Next
End If
End If

End Sub