One of the joys I have is editing complex tables where previous authors have put multiple items in a single cell. Cutting and pasting this this text works well if the seperator is a paragraphmarker but no so well if its a comma. There is also the issue of selecting the text in the cell rather than the cell itself.
To simplify my life I wrote a macro that takes a range of cells, finds the first cell with appropriate text and then distributes it across the range splitting by a separator.
In writing this macro I came across a bug with the selection range.
If you count the cells in the selection using selection.range.count then for a horizontal range you get the number of cells highlighted.
If the selection is vertical then the count reflects all cells starting at the first cell in the range and then counting horizontally from the first cell of the selection all cells in the row and rows below until it reaches the last cell in the selection range. the same happens for a range object.
To get around this issue I had to scan the selection range and then add cells to a collection if they had the same columnindex as the first cell in the selection range..
The code to do the whole thing (ugly and inefficient as it may be) is below. Regular visitor will note that thanks to repeated copaching by Macropod, the only reference to selection is to get the selection range into a range object
Please feel free to make suggestions about improving the code
Code:
Sub sbSplitTextInOneCellAcrossRange()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Takes a range of cells from an on screen selection
' Finds the first cell with text
' Distributes the text across the range of cells starting with the first cell
' Splits text by paragreaph marker or if no pragraph markers by other markers
' in the order <comma> <semi-colon> <space>
' If no marker is found then the user is invited to enter a seperator
' The text to split can be anywherein the range
'
' If the range is spanned by a merged cell then this cell is not included in the range
' This doesn't affect me but it might you so this is something to fix.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim myCellWithText As Long
Dim myCells As Collection
Dim myCellsText() As String
Dim tmptext As String
Dim myNoTextFound As Boolean
Dim thisCell As Cell
Dim myRange As Range
Dim myRangeMemory As Object
Dim myIndex As Long
Dim mySeparator As String
Dim myLastCellConsolidated As Boolean
Dim myFirstCellColumnIndex As Long
Dim myVertical As Boolean
Set myRange = Selection.Range
Set myRangeMemory = Nothing
Set myRangeMemory = myRange
Set myCells = New Collection
myVertical = False
' check there is more than one cell in the range
If Selection.Range.Cells.Count = 1 Then
MsgBox "The selected range must have more than one cell", vbCritical
Exit Sub
End If
' Word has a bug. In a vertical selection it counts all the cells going horizontally
' from the first cell in the selection to the last
' so we need to make a collection of our cells with the same columnindex as the first
myFirstCellColumnIndex = myRange.Cells(1).ColumnIndex
If myRange.Cells(1).ColumnIndex = myRange.Cells(myRange.Cells.Count).ColumnIndex Then
myVertical = True
End If
myIndex = 1
Debug.Print myFirstCellColumnIndex
For Each thisCell In myRange.Cells
If myVertical Then
Debug.Print thisCell.ColumnIndex
If thisCell.ColumnIndex = myFirstCellColumnIndex Then
myCells.Add Key:=Str(myIndex), Item:=thisCell
myIndex = myIndex + 1
End If
Else
myCells.Add Key:=Str(myIndex), Item:=thisCell
myIndex = myIndex + 1
End If
Next
Set myRange = Selection.Range
Set myRangeMemory = Nothing
Set myRangeMemory = myRange
'remove multiple paragraphmarkers
sbResetFindReplaceStickyParameters
With myRange.Find
.Text = ChrW(13) & "{1,}"
.Replacement.Text = "^p"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Set myRange = myRangeMemory
myRange.Select
'remove pargraphmarkers at the end of cells as they cause problems
' and also if the cell is left with a - (common in my tables to mark an empty cell)
'also check if we are left with a - if so delete it
For myIndex = 1 To myCells.Count
If myCells(myIndex).Range.Characters.Count > 1 Then
If myCells(myIndex).Range.Characters.Last.Previous = ChrW(13) Then
myCells(myIndex).Range.Characters.Last.Previous.Delete
If myCells(myIndex).Range.Characters.Count > 1 Then
If myCells(myIndex).Range.Characters.Last.Previous = "-" Then
myCells(myIndex).Range.Characters.Last.Previous.Delete
End If
End If
End If
End If
Next
' Check there is text in one of the cells in the selected range
myNoTextFound = True
For myIndex = 1 To myCells.Count
If myCells(myIndex).Range.Characters.Count > 1 Then
myNoTextFound = False
Exit For
End If
Next
If myNoTextFound Then
MsgBox "Oooops! No text in selected range", vbCritical
Exit Sub
End If
' Find the character that is the separator for the text items
' search and replace works only in the selected range unlike .cells.count
sbResetFindReplaceStickyParameters
With myRange.Find
.Text = "[" & ChrW(13) & ",; " & "]"
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
If .Found Then
mySeparator = myRange.Characters.Last
End If
End With
' If we didin't find the separator ask for a user defined separator
If mySeparator = "" Then
mySeparator = InputBox("No separator of type paragraph marker, comma, semicolon or space found" & ChrW(13) & "Please enter sa single charactre that is the list separator for the text in the selected range", vbOKCancel)
If mySeparator = "" Then
Exit Sub
End If
End If
' Find cell with text
For myIndex = 1 To myCells.Count
' Ignore where we might still have a '-' in a cell
myCells(myIndex).Range.Select
If myCells(myIndex).Range.Characters.Count > 2 Then
myCellWithText = myIndex
Exit For
End If
Next
' Populate mycellstext with the available text
myCellsText() = Split(Trim(myCells(myCellWithText).Range.Text), mySeparator)
' Populate cells
' mycellstext arreay starts at 0 but mycells collection start at 1
For myIndex = LBound(myCellsText) To UBound(myCellsText) - 1
' mycellstext may have more members than mycells so concatenate the excess into the last cell
If myIndex + 1 <= myCells.Count Then
myCells(myIndex + 1).Range.Text = Trim(myCellsText(myIndex))
Else
myCells(myCells.Count).Range.Text = myCells(myCells.Count).Range.Text & mySeparator & Trim(myCellsText(myIndex))
myLastCellConsolidated = True
End If
Next
If myLastCellConsolidated Then
MsgBox "There was more text then cells so excess text is in the last cell of the range.", vbCritical
End If
End Sub
Sub sbResetFindReplaceStickyParameters()
' The use of a range object is critical to the success of this macro
Dim myRange As Range
Set myRange = ActiveDocument.StoryRanges(wdMainTextStory) ' actually any range object will do
With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop ' This means stop when we get to the end of the document
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub