|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Distribute text in one cell across a range of cells (overcoming selection.range.cells.count bug)
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 Last edited by slaycock; 02-18-2017 at 08:53 AM. Reason: TNow works with vetical and horzontal rranges. Added code for sbResetFindReplaceStickyParameters |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
If (cell) is (range of cells), then (cell) should be (range of cells) | ExcelPatient | Excel | 5 | 11-08-2016 07:21 AM |
If value of cell A Matches a value in a Range of cells (column) then add value of cell A to cell C | rick10r | Excel | 1 | 07-05-2016 12:07 PM |
Search Range Within Cell or Cells | COEngineer | Excel | 1 | 06-01-2016 11:50 AM |
Copying text range of cells to different cells adds an extra line | jpb103 | Word VBA | 2 | 07-23-2014 12:22 PM |
Count range cells eliminating merge cells | danbenedek | Excel | 0 | 06-15-2010 12:40 AM |