Thread: [Solved] Macro to split table cells
View Single Post
 
Old 03-08-2016, 04:07 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,366
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

It would have been helpful had you specified your requirements in full from the outset. Try:
Code:
Sub ReformatTables()
Dim t As Long, i As Long, StrDrwgs As String, StrTypes As String
Dim StrEngineer As String, StrTED As String, StrTPD As String, Rng As Range
With ActiveDocument
  For t = .Tables.Count To 1 Step -1
    With .Tables(t)
      If Trim(Split(.Cell(1, 2).Range, Chr(13))(0)) = "Drawings" Then
        StrDrwgs = Trim(Split(.Cell(2, 2).Range, Chr(13))(0))
        StrTypes = Trim(Split(.Cell(2, 3).Range, Chr(13))(0))
        For i = 1 To UBound(Split(StrDrwgs, ","))
          With .Rows.Last.Range
            .Next.InsertBefore vbCr
            .Next.FormattedText = .FormattedText
          End With
          With .Rows.Last.Range
            .Cells(1).Range.Text = i + 1
            .Cells(2).Range.Text = Trim(Split(StrDrwgs, ",")(i))
            .Cells(3).Range.Text = Trim(Split(StrTypes, ",")(i))
          End With
        Next
        With .Rows(2).Range
          .Cells(1).Range.Text = 1
          .Cells(2).Range.Text = Trim(Split(StrDrwgs, ",")(0))
          .Cells(3).Range.Text = Trim(Split(StrTypes, ",")(0))
        End With
      End If
      If Trim(Split(.Cell(1, 2).Range, Chr(13))(0)) = "Project Engineer" Then
        .Split .Rows.Count
        StrEngineer = Trim(Split(.Cell(2, 2).Range, Chr(13))(0))
        StrTED = Trim(Split(.Cell(2, 3).Range, Chr(13))(0))
        StrTPD = Trim(Split(.Cell(2, 4).Range, Chr(13))(0))
        For i = 1 To UBound(Split(StrEngineer, ","))
          With .Rows.Last.Range
            .Next.InsertBefore vbCr
            .Next.FormattedText = .FormattedText
          End With
          With .Rows.Last.Range
            .Cells(2).Range.Text = Trim(Split(StrEngineer, ",")(i))
            .Cells(3).Range.Text = Trim(Split(StrTED, ",")(i))
            .Cells(4).Range.Text = Trim(Split(StrTPD, ",")(i))
          End With
        Next
        With .Rows(2).Range
            .Cells(2).Range.Text = Trim(Split(StrEngineer, ",")(0))
            .Cells(3).Range.Text = Trim(Split(StrTED, ",")(0))
            .Cells(4).Range.Text = Trim(Split(StrTPD, ",")(0))
        End With
        .Range.Characters.Last.Next.Delete
      End If
    End With
  Next
End With
End Sub
PS: There is no need to quote every post you reply to - doing so just adds clutter.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote