Moving Words from Current Cell to Below Cells Based On Condition

[madhuchelliah]

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.

C	I
XXXX	AAAA
YYYY	BBBB
ZZZZ	CCCC
John Harry James Anna	..Maths .Science ..English ...History

<tbody>
</tbody>

Result

C	I
XXXX	AAAA
YYYY	BBBB
ZZZZ	CCCC
John	..Maths
Harry	.Science
James	..English
Anna	...History

<tbody>
</tbody>

 

[mumps]

Try:

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

 

[Fluff]

Another option is

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

 

[madhuchelliah]

Another option is

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.

 

[Fluff]

Could you have a space between the dots & the word?

 

[madhuchelliah]

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.

 

[Rick Rothstein]

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?

 

[madhuchelliah]

Are the dotted values only confined to Column I or could Column C have them also?

Hello Rick, Dotted values only in I column. Thank you.

 

[Rick Rothstein]

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.

[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]

 

[madhuchelliah]

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.

[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.