CODEWITHSUNDEEP
excelvbams-word
JoshL
JoshL

Reputation: 164

Automatically Transfer from Excel to a Tab Delimited List in Word

I have a table in excel which has the data I would like to transfer to a word document. Based on which column the values are in I am trying to put the data into a different tabbed order (Ex: List Level 1 is initial list, List Level 2 is pressing tab once in list).

I am trying to do this by recognizing a cell on a previous sheet and the code I have so far works to get the word document open but in order to actually bring in the data I can't seem to figure it out.

enter image description here

My current code is show below (I have the word document "Template.docx" in the same folder:

Private Sub CreateList()

Dim WRD As Object, DOC As Object
On Error Resume Next
Set WRD = CreateObject("Word.Application")
If Err.Number <> 0 Then
    Set WRD = CreateObject("Word.Application")
End If
On Error GoTo 0

Set DOC = WRD.Documents.Open(ThisWorkbook.Path & 
"\Template.docx", ReadOnly:=True)

WRD.Visible = True

If Sheet1.Range("A1").Value = "Package 1" Then

    With DOC

    ' INSERT DATA FROM EXCEL INTO A TAB DELIMITED LIST

    End With

End If

Set WRD = Nothing
Set DOC = Nothing

End Sub

Upvotes: 0

Views: 147

Answers (1)

macropod
macropod

Reputation: 13490

You refer to a tab-delimited list in Word, but your pic depicts something that would ordinarily be dealt with as paragraph headings in Word.

Assuming you really want headings and that your Word document employs Word's Heading Styles with multi-level list-numbering correctly, you could use something like:

Sub CreateList()
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlSht As Worksheet, sPath As String, LRow As Long, LCol As Long, r As Long, c As Long
sPath = ActiveWorkbook.Path: Set xlSht = ActiveSheet
With xlSht.Cells.SpecialCells(xlCellTypeLastCell)
  LRow = .Row: LCol = .Column: If LCol > 9 Then LCol = 9
End With
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Open(Filename:=sPath & "\Template.docx", AddToRecentFiles:=False, ReadOnly:=True, Visible:=True)
  With wdDoc
    For r = 2 To LRow
      For c = 1 To LCol
        If xlSht.Cells(r, c).Value <> "-" Then
          .Characters.Last.InsertBefore xlSht.Cells(r, c).Value & vbCr & vbCr
          .Characters.Last.Previous.Previous.Style = "Heading " & c
        End If
      Next
    Next
  End With
  .Visible = True
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub

If you're wedded to using list-level numbering, you could replace the:

        If xlSht.Cells(r, c).Value <> "-" Then
          ...
        End If

code block with something like:

        If xlSht.Cells(r, c).Value <> "-" Then
          .Characters.Last.InsertBefore xlSht.Cells(r, c).Value & vbCr & vbCr
          With .Paragraphs(.Paragraphs.Count - 2).Range.ListFormat
             .ApplyListTemplateWithLevel ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(2), _
                ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:=wdWord9ListBehavior
             .ListLevelNumber = c
          End With
        End If

and insert:

    For c = 1 To LCol ' or 9 for all possible levels
      .ListTemplates(2).ListLevels(c).TextPosition = InchesToPoints(c * 0.5 - 0.5)
      .ListTemplates(2).ListLevels(c).ResetOnHigher = True
    Next

after the existing final 'Next'.

If the above doesn't provide the list numbering format you want, you will need to choose the appropriate ListGallery (from wdBulletGallery, wdNumberGallery, or wdOutlineNumberGallery) and the and ListTemplate number.

Upvotes: 1

Related Questions