相關文章：

【VBA範例】：含有合併欄之Excel檔案如何排序
【VBA範例】：如何在MS Word中控制Excel

若運用VBA得當，不但Word可以操控Excel，Excel也可以操控Word．

因為Excel無法計算字數，欲在Excel中計算字數，必須借用Word的算字功能．

下面這個程式將Excel中所選之區域貼到Word中，算出字數之後，將結果存回Excel．

====================================================
Option Explicit

Sub count_in_Word()

'在Excel中使用MS Word來計算稿名字數

'
'使用方法
'假設稿名旁邊那一行空白
'一、選擇要計算的稿名
'二、執行本程式
'
'In order to use this code you must set a reference to the
'Word object library by doing this. In the VB Editor click
'Tools, References. Then search for Microsoft Word n.n Object Library
'where n.n will depend on your version of Word.
'
'本程式最後修改日期：2008-8-21
'

Dim wdApp As Word.Application, wdDoc As Word.Document
Dim oWdRange As Word.Range
Dim iLoop As Integer
Dim iRow As Integer
Dim iColumn As Integer
Dim l As Integer
Dim n As Integer
Dim m As Integer
Dim iBlock As Integer
Dim iRemainder As Integer
Dim iTotalWords1 As Integer
Dim iTotalWords2 As Integer

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

On Error Resume Next

Set wdApp = GetObject(, "Word.Application")

If Err.Number <> 0 Then 'Word isn't already running

Set wdApp = CreateObject("Word.Application")

End If

On Error GoTo 0

Set wdDoc = wdApp.Documents.Add("Normal", False, 0)

'儲存時間，以計算本程式之執行時間

Cells(1, 6) = Now()

ThisWorkbook.Sheets("sheet1").Select

'找出選區之第一格及總格數

With Selection

iRow = Selection.Row()
iColumn = Selection.Column()
iLoop = Selection.Rows.Count

End With

'每次處理六格

iBlock = 6

'算餘數

iRemainder = iLoop Mod iBlock

'一定得用\，不能用/．後者會自動四捨五入

m = iLoop \ iBlock

For l = 1 To m

'每六格一選

Range(Cells(iRow + (l - 1) * iBlock, iColumn), Cells(iRow + l * iBlock - 1, iColumn)).Select

With Selection

Selection.Copy

End With

'貼到MS Word

wdApp.Selection.PasteSpecial DataType:=wdPasteText

For n = 1 To iBlock

'先算總字數

iTotalWords1 = wdApp.ActiveDocument.ComputeStatistics(wdStatisticWords)

'選取第一段，刪除之後，再算總字數．二者差額即第一段之字數

Set oWdRange = wdApp.ActiveDocument.Paragraphs(1).Range

oWdRange.Delete

iTotalWords2 = wdApp.ActiveDocument.ComputeStatistics(wdStatisticWords)

'將算出之字數存回Excel

Cells(iRow + (l - 1) * iBlock + n - 1, iColumn + 1).Value = iTotalWords1 - iTotalWords2

Next n

Next l

'處理最後一段

If iRemainder Then

Range(Cells(iRow + (l - 1) * iBlock, iColumn), Cells(iRow + (l - 1) * iBlock + iRemainder - 1, iColumn)).Select

With Selection

Selection.Copy

End With

wdApp.Selection.PasteSpecial DataType:=wdPasteText

For n = 1 To iRemainder

'先算總字數

iTotalWords1 = wdApp.ActiveDocument.ComputeStatistics(wdStatisticWords)

'選取第一段，刪除之後，再算總字數．二者差額即第一段之字數

Set oWdRange = wdApp.ActiveDocument.Paragraphs(1).Range

oWdRange.Delete

iTotalWords2 = wdApp.ActiveDocument.ComputeStatistics(wdStatisticWords)

Cells(iRow + (l - 1) * iBlock + n - 1, iColumn + 1).Value = iTotalWords1 - iTotalWords2

Next n

End If

Cells(2, 6) = Now()

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

wdDoc.Close False

wdApp.Quit

End Sub
==============================================
相關文章：

VBA範例：含有合併欄之Excel檔案如何排序
VBA範例：如何在MS Word中控制Excel