Solved: How do I do preformatting in excel and copy that formatting + data over to word?

[thedark123]

Here are 2 screenshots:

My supervisor suggested this way to me:

Preformat the cells, columns, table and everything in excel first then copy that whole chunk over to word and vola.

firstly is the raw data from excel:




secondly is what I wan to achieve:

[lucas]

http://www.vbaexpress.com/forum/showthread.php?t=8459

[mdmackillop]

So why not do what your supervisor suggests?
[VBA]
Sub PasteFormattedCells()
Dim wdApp As Word.Application

Set wdApp = New Word.Application
With wdApp
.Documents.Add
.Visible = True
.WindowState = wdWindowStateMaximize
Range("A1:B5").Copy
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
End With
End Sub

[/VBA]

[thedark123]

How do I use this coding?

[VBA] .Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False [/VBA]

to make it format like the table below, exactly the same formatting

[mdmackillop]

My supervisor suggested this way to me:
Preformat the cells, columns, table and everything in excel first then copy that whole chunk over to word and vola.

I don't know what more there is to say.

[thedark123]

ok it is working already.... my code

1)The border of the table seems to be missing how to enable it?
2) How to make 1 table per page instead of 3-4 in a page..
Page Break?



[vba]Private Sub CommandButton1_Click()

Dim x
Dim lCount As Long
Dim lMax As Integer
Dim lMax1() As Integer
Dim lCount1() As Integer
Dim title() As String
Dim WS_Count As Integer
Dim i As Integer
Dim LastCol() As Integer



' Prompt the user for the folder to list.
x = InputBox("What folder do you want to list?" & Chr$(13) & Chr$(13) _
& "For example: C:\My Documents")

If x = "" Or x = " " Then
Response = MsgBox("Please Enter a Directory Location" _
& Chr$(13) & Chr$(13) & _
"To enter directory location, click No." & Chr$(13) & _
"To Exit, click Yes.", vbYesNo)
If Response = "6" Then
End If
Else

' Search Drive
ChDrive "C"
ChDir x

On Error Resume Next

' Place .xls files into Worksheet and tabulate data
outrow = 2
filess = Dir("*.xls")

While Not filess = ""
Workbooks.Open Filename:=filess, UpdateLinks:=False

' requires a reference to the Word Object library:
' in the VBE select Tools, References and check the Microsoft Word X.X object library
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Dim totalcolumn As Integer
Dim MyFol As String
Dim newfol As String
Dim scenario_id As Integer
Dim rule_id As String
Dim desc As String
Dim fields As String
Dim error As String
Dim results As String

Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
newfol = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 4)

' Create a directory for each workbook by the same name
MkDir (newfol)
MyFol = newfol & "\"
On Error Resume Next

For Each ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & ws.Name & "..."
totalcolumn = WorksheetFunction.Max(ws.Range("3:3")) + 3

For i = 4 To totalcolumn

' Extract the values from excel
scenario_id = ws.Cells(3, i).Value
rule_id = ws.Cells(5, i).Value
desc = ws.Cells(6, i).Value
fields = ws.Cells(7, i).Value
error = ws.Cells(8, i).Value
results = ws.Cells(11, i).Value

' Application.CutCopyMode = False
ws.Range(ws.Cells(1, 1), ws.Cells(1, 1)).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
Set wdTbl = wdDoc.Tables.Add(Range:=wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range, NumRows:=11, NumColumns:=2)
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter


' Insert table with extracted values
With wdTbl


.Cell(1, 1).Range.Text = "Test Data ID:"
.Cell(2, 1).Range.Text = "Scenario ID:"
.Cell(3, 1).Range.Text = "Tester:"
.Cell(4, 1).Range.Text = "Date (DD/MM/YYYY):"
.Cell(5, 1).Range.Text = "Results:"
.Cell(6, 1).Range.Text = "Trouble Ticket No:"
.Cell(7, 1).Range.Text = "Test Condition:"
.Cell(8, 1).Range.Text = "Rule ID:"
.Cell(9, 1).Range.Text = "Rule Description:"
.Cell(10, 1).Range.Text = ""
.Cell(11, 1).Range.Text = ""


.Cell(1, 2).Range.Text = ws.Name
.Cell(2, 2).Range.Text = scenario_id
.Cell(3, 2).Range.Text = ""
.Cell(4, 2).Range.Text = ""
.Cell(5, 2).Range.Text = results
.Cell(6, 2).Range.Text = ""
.Cell(7, 2).Range.Text = ""
.Cell(8, 2).Range.Text = rule_id
.Cell(9, 2).Range.Text = desc
.Cell(10, 2).Range.Text = fields
.Cell(11, 2).Range.Text = error
End With

' Format table
With wdTbl
.Rows(1).Range.Bold = True
.Rows(2).Range.Bold = True
.Rows(3).Range.Bold = True
.Rows(4).Range.Bold = True
.Rows(5).Range.Bold = True
.Rows(6).Range.Bold = True
.Rows(7).Range.Bold = True
.Rows(8).Range.Bold = True
.Rows(9).Range.Bold = True
.Rows(10).Range.Bold = True
.Rows(11).Range.Bold = True
.Cell(1, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(2, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(3, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(4, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(5, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(6, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(7, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(8, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(9, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(10, 1).Shading.BackgroundPatternColor = wdColorGray15
.Cell(11, 1).Shading.BackgroundPatternColor = wdColorGray15
.Rows(1).HeadingFormat = True
.Rows(2).HeadingFormat = True
.Rows(3).HeadingFormat = True
.Rows(4).HeadingFormat = True
.Rows(5).HeadingFormat = True
.Rows(6).HeadingFormat = True
.Rows(7).HeadingFormat = True
.Rows(8).HeadingFormat = True
.Rows(9).HeadingFormat = True
.Rows(10).HeadingFormat = True
.Rows(11).HeadingFormat = True
End With
Set wdTbl = Nothing
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
' insert page break after all Worksheets except the last one
If Not i = totalcolumn Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next i

'Save as sheet name and close
wdDoc.SaveAs Filename:=MyFol & ws.Name & ".doc"

Next ws
'wdDoc.Close

Set ws = Nothing
Application.StatusBar = "Cleaning up..."

' apply normal view
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False

filess = Dir()
Wend
End If
End Sub


[/vba]

[mdmackillop]

Two things
Line breaks are essential if you wish your code to be read.
I'm offering one solution, you are coming back with code which doesn't use it.

[thedark123]

Solved thanks ^^