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