Sub ExportExcel2Word_AllF()
Dim DataC As Long, Tg
Dim dem As Long, EndR As Long, EndC As Long
Dim objRange, objTable
Dim wDoc, aWord
Dim FCol As Long, LCol As Long, i As Long
Const CFont = "Times New Roman"
Const CSize = "14"
Const CColor_Normal = wdColorDarkGreen
Const CColor_Table = wdColorDarkBlue
Tg = Timer()
Set aWord = CreateObject("Word.Application")
'TAO FILE WORD
Set wDoc = aWord.Documents.Add
aWord.Visible = True
'SHEET NGUON: Dem cot, dem dong
For FCol = 1 To 100
If Cells(65536, FCol).End(xlUp).Row > 10 Then Exit For
Next FCol
EndR = Cells(65536, FCol).End(xlUp).Row + 2
Cells(1, FCol).Select
For dem = 1 To EndR
Cells(dem, FCol).Select
If LCol < Selection.Columns.Count Then LCol = Selection.Columns.Count
Next dem
LCol = LCol + FCol - 1
Cells(1, FCol).Select
'CHEP TU DAU DEN CUOI VB
Application.ScreenUpdating = False
For i = 1 To EndR
'Neu khong chia nhieu cot
If WorksheetFunction.CountA(Range(Cells(i, FCol), Cells(i, LCol))) = 1 Or WorksheetFunction.CountA(Range(Cells(i, FCol), Cells(i, LCol))) = 0 Then
'Cell hien hanh khong co du lieu -> chep nguyen dong hien hanh
If Cells(i, FCol) = "" Then
Range(Cells(i, FCol), Cells(i, LCol)).Copy
Set objRange = wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
objRange.Paste
With objRange
.Font.Name = CFont
.Font.Size = CSize
.Font.Color = CColor_Table
End With
Else
wDoc.Range.InsertAfter Cells(i, FCol) & vbCrLf 'Chep du lieu neu co
End If
'Dinh dang doan van ban
With wDoc.Paragraphs(wDoc.Paragraphs.Count - 1).Range
.Font.Name = CFont
.Font.Size = CSize
.Font.Color = CColor_Normal
'Dinh dang cac dong co font chu Dam
If Cells(i, FCol).Font.Bold = True Then
.Font.Bold = True
End If
'Can chinh
If Cells(i, FCol).HorizontalAlignment = xlCenter Then
.ParagraphFormat.Alignment = wdAlignParagraphCenter
Else
.ParagraphFormat.Alignment = wdAlignParagraphJustify
End If
'Gian cach giua 2 doan van ban
.ParagraphFormat.SpaceBefore = 6
.ParagraphFormat.SpaceBeforeAuto = False
.ParagraphFormat.SpaceAfter = 3
.ParagraphFormat.SpaceAfterAuto = False
End With
'Neu tai cac dong co nhieu cot
Else
If WorksheetFunction.CountA(Range(Cells(i, FCol), Cells(i, LCol))) > 1 Then
If Cells(i, FCol).Borders(xlEdgeTop).LineStyle = xlContinuous Then
For dem = i To EndR
If Cells(dem, FCol).Borders(xlEdgeRight).LineStyle = xlNone Then Exit For
Next dem
Range(Cells(i, FCol), Cells(dem - 1, LCol)).Copy
'Cells(dem - 1, FCol).Select
i = dem - 1
Else
Range(Cells(i, FCol), Cells(i, LCol)).Copy
End If
'Chep Table tu Excel sang Word
Set objRange = wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
'On Error Resume Next
objRange.Paste
With objRange
.Font.Name = CFont
.Font.Size = CSize
.Font.Color = CColor_Table
End With
'On Error GoTo 0
End If
End If
Next i
'Dinh dang le trang in
With wDoc.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(3.3)
.RightMargin = CentimetersToPoints(1.5)
End With
Dim oTbl As Object, oTblX As Object
Set oTblX = wDoc.Tables(1)
oTblX.AutoFitBehavior (wdAutoFitContent)
For Each oTbl In wDoc.Tables
oTbl.Rows.LeftIndent = oTbl.Rows.LeftIndent - PicasToPoints(1.45)
Next oTbl
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Tong thoi gian la " & Round(Timer() - Tg, 2) & " giay"
'Call LuuFileWord
aWord.Activate 'Xem ket qua
Set wDoc = Nothing
Set aWord = Nothing
End Sub