Moving Words from Current Cell to Below Cells Based On Condition

madhuchelliah

Board Regular
Joined
Nov 22, 2017
Messages
226
Office Version
  1. 2019
Platform
  1. Windows
Hello Folks. I used to export tables in PDF to excel. Sometimes all the words in the columns saved as a single cell. This cell is always the last used row. Each word is separated by space and Dot (.) in their respective columns. Now i want to move the words downward in their respective columns i.e C and I.The I column used to start with dot. The word should separate with dots and move to the cells below. See the example below. I know its a hectic task. Please heads up. Thank you.

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD="align: center"]C
[/TD]
[TD="align: center"]I
[/TD]
[/TR]
[TR]
[TD="align: center"]XXXX
[/TD]
[TD="align: center"]AAAA
[/TD]
[/TR]
[TR]
[TD="align: center"]YYYY
[/TD]
[TD="align: center"]BBBB
[/TD]
[/TR]
[TR]
[TD="align: center"]ZZZZ
[/TD]
[TD="align: center"]CCCC
[/TD]
[/TR]
[TR]
[TD="align: center"]John Harry James Anna
[/TD]
[TD="align: center"]..Maths .Science ..English ...History
[/TD]
[/TR]
</tbody>[/TABLE]










Result

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD="align: center"]C
[/TD]
[TD="align: center"]I
[/TD]
[/TR]
[TR]
[TD="align: center"]XXXX
[/TD]
[TD="align: center"]AAAA
[/TD]
[/TR]
[TR]
[TD="align: center"]YYYY
[/TD]
[TD="align: center"]BBBB
[/TD]
[/TR]
[TR]
[TD="align: center"]ZZZZ
[/TD]
[TD="align: center"]CCCC
[/TD]
[/TR]
[TR]
[TD="align: center"]John
[/TD]
[TD="align: center"]..Maths
[/TD]
[/TR]
[TR]
[TD="align: center"]Harry
[/TD]
[TD="align: center"].Science
[/TD]
[/TR]
[TR]
[TD="align: center"]James
[/TD]
[TD="align: center"]..English
[/TD]
[/TR]
[TR]
[TD="align: center"]Anna
[/TD]
[TD="align: center"]...History
[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Try:
Code:
Sub SplitCells()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim splitC As Variant
    Dim splitI As Variant
    splitC = Split(Cells(LastRow, "C"), " ")
    splitI = Split(Cells(LastRow, "I"), " ")
    Dim i As Long
    For i = LBound(splitC) To UBound(splitC)
        Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = splitC(i)
    Next i
    For i = LBound(splitI) To UBound(splitI)
        Cells(Rows.Count, "I").End(xlUp).Offset(1, 0) = splitI(i)
    Next i
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Another option is
Code:
Sub SplitData()

   Dim Rng As Range
   Set Rng = Range("C" & Rows.Count).End(xlUp)
   Rng.Resize(UBound(Split(Rng, " ")) + 1).Value = Application.Transpose(Split(Rng, " "))
   Rng.Offset(, 6).Resize(UBound(Split(Rng.Offset(, 6), " ")) + 1).Value = Application.Transpose(Split(Rng.Offset(, 6), " "))

End Sub
 
Upvote 0
Another option is
Code:
Sub SplitData()

   Dim Rng As Range
   Set Rng = Range("C" & Rows.Count).End(xlUp)
   Rng.Resize(UBound(Split(Rng, " ")) + 1).Value = Application.Transpose(Split(Rng, " "))
   Rng.Offset(, 6).Resize(UBound(Split(Rng.Offset(, 6), " ")) + 1).Value = Application.Transpose(Split(Rng.Offset(, 6), " "))

End Sub

Hello Fluff, working cool. I appreciate your efforts. I have a concern in I column. Sometimes i have space between the dots,in that case the code is not work as expected.
The code should bring down from the dot starts not based on space. It will be fine if I column has separate code. Thank you.
 
Upvote 0
Could you have a space between the dots & the word?
 
Upvote 0
Could you have a space between the dots & the word?

Yes. There is space between dots and he words. I can say the code should bring down the content from when dot starts upto before the next dots. Thank you.
 
Upvote 0
Yes. There is space between dots and he words. I can say the code should bring down the content from when dot starts upto before the next dots. Thank you.
Are the dotted values only confined to Column I or could Column C have them also?
 
Last edited:
Upvote 0
Hello Rick, Dotted values only in I column. Thank you.
Okay, the following code assumes two things... one, that your subjects names could have spaces in them (such as "Advanced Math"), and two, that each subject has at least one preceding dot.
Code:
[table="width: 500"]
[tr]
	[td]Sub WordsToSingleCells()
  Dim C As Long, X As Long, Word As Variant
  Dim Txt As String, Arr() As String, Answer() As String
  With Cells(Rows.Count, "C").End(xlUp)
    Arr = Split(.Value)
    .Resize(UBound(Arr) + 1) = Application.Transpose(Arr)
  End With
  With Cells(Rows.Count, "I").End(xlUp)
    Txt = Trim(.Value)
    Arr = Split(Application.Trim(Replace(Txt, ".", " ")))
    ReDim Answer(1 To UBound(Arr) + 1, 1 To 1)
    For Each Word In Arr
      X = X + 1
      Answer(X, 1) = Trim(Left(Txt, InStr(Txt, Word) + Len(Word)))
      If Left(Answer(X, 1), 1) <> "." Then
        Answer(X - 1, 1) = Answer(X - 1, 1) & " " & Answer(X, 1)
        Answer(X, 1) = ""
        X = X - 1
      End If
      Txt = Trim(Mid(Txt, InStr(Txt, Word) + Len(Word)))
    Next
    .Resize(UBound(Answer)) = Answer
  End With
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Okay, the following code assumes two things... one, that your subjects names could have spaces in them (such as "Advanced Math"), and two, that each subject has at least one preceding dot.
Code:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub WordsToSingleCells()
  Dim C As Long, X As Long, Word As Variant
  Dim Txt As String, Arr() As String, Answer() As String
  With Cells(Rows.Count, "C").End(xlUp)
    Arr = Split(.Value)
    .Resize(UBound(Arr) + 1) = Application.Transpose(Arr)
  End With
  With Cells(Rows.Count, "I").End(xlUp)
    Txt = Trim(.Value)
    Arr = Split(Application.Trim(Replace(Txt, ".", " ")))
    ReDim Answer(1 To UBound(Arr) + 1, 1 To 1)
    For Each Word In Arr
      X = X + 1
      Answer(X, 1) = Trim(Left(Txt, InStr(Txt, Word) + Len(Word)))
      If Left(Answer(X, 1), 1) <> "." Then
        Answer(X - 1, 1) = Answer(X - 1, 1) & " " & Answer(X, 1)
        Answer(X, 1) = ""
        X = X - 1
      End If
      Txt = Trim(Mid(Txt, InStr(Txt, Word) + Len(Word)))
    Next
    .Resize(UBound(Answer)) = Answer
  End With
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Hello Rick, Working Great. you are awesome. Thank you.
 
Upvote 0

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

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