|
这几天我很忙，抽空做了一个示例，请楼主测试一下，另外，按月打印是否与其它项目有关，比如期数后按月？你的数据多不多，可能需要重新考虑程序问题。
Private Sub CommandButton1_Click()
Dim WdApp As Word.Application, WdDoc As Word.Document, I As Byte, myRange As Range
Dim Firstrange As String, LastRange As String, a As Range, M As Byte, N As Byte, TF As Boolean
Dim Msg, Style, Title, Help, Ctxt, Response, MyString, wdRange As Word.Range
Dim myArray() As String, L As Integer, aTable As Word.Table, aCell As Word.Cell
With Sheets(1)
LastRange = .[A65536].End(xlUp).Address
Set myRange = .Range("A3:" & LastRange)
MyString = VBA.InputBox("ÇëÊäÈëÐèÒª´òÓ¡µÄÖ¸¶¨ÆÚÊý!", Title:="Excel_Word", Default:=1)
If MyString = "" Then Exit Sub
MyString = VBA.Val(MyString)
MyString = VBA.Format(MyString, "0000")
Set a = myRange.Find(What:=MyString, LookIn:=xlValues, LookAt:=xlWhole)
If a Is Nothing Then
MsgBox "ExcelδÔÚÖ¸¶¨µÄÁÐÖвéÕÒµ½¸ÃÆÚÊýÖµ,ÇëÈ·ÈÏ!", vbInformation + vbOKOnly
Exit Sub
Else
Set myRange = .Range(a.Address & ":" & LastRange)
End If
End With
On Error Resume Next 'ºöÂÔ´íÎó
Application.ScreenUpdating = False '¹Ø±ÕÆÁÄ»¸üÐÂ
Set WdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
TF = True
Set WdApp = CreateObject("Word.Application") '´´½¨Ò»¸öWORD³ÌÐò
End If
Set WdDoc = WdApp.Documents.Open(ThisWorkbook.Path & "\ÆÚÊý.dot")
WdApp.Visible = True
With WdDoc
I = 1 '³õʼ»¯±äÁ¿
For Each a In myRange
Set wdRange = .Range(.Content.End - 1, .Content.End - 1)
If I > 20 Or I = 1 Then
ReDim Preserve myArray(L)
myArray(L) = "ÊÕÊÓÂÊ": L = L + 1
I = 1: N = N + 1 'I³õʼ»¯,NÖµÀÛ¼Ó
.AttachedTemplate.AutoTextEntries("ÆÚÊý").Insert where:=wdRange, RichText:=True
End If
ReDim Preserve myArray(L)
myArray(L) = VBA.Format(a.Offset(, 5), "Percent")
L = L + 1
With .Tables(N)
For M = 1 To 5
Select Case M
Case 1
.Cell(I + 1, M).Range = VBA.Format(a.Offset(, M - 1).Value, "0000")
Case 4
.Cell(I + 1, M).Range = VBA.Format(a.Offset(, M - 1).Value, "YYYYÄêMMÔÂDDÈÕ aaaa")
Case Else
.Cell(I + 1, M).Range = a.Offset(, M - 1).Value
End Select
Next M
End With
I = I + 1 'ÀÛ¼Ó
Next
Application.ScreenUpdating = True '»Ö¸´ÆÁÄ»¸üÐÂ
WdApp.Visible = True
Msg = "Îĵµ¸ñʽΪ¡º¡ù¡ù¡ù¡ù¡ù¡»×¨Êô¹«¸æ¸ñʽ£¬ÈçÐèÐ޸ģ¬Çë֪ͨÏà³ÌÐò¿ª·¢¹ØÈËÔ±ÐÞÕý£¡ÊÇ·ñ¿ªÊ¼´òÓ¡£¿"
Style = vbYesNo + vbCritical + vbDefaultButton1 ' ¶¨Òå°´Å¥¡£
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' Óû§°´Ï¡°ÊÇ¡±¡£
If MsgBox("ÊÇ·ñÐèÒª½«½ø¶ÈÊý¾ÝÐÞ¸ÄΪÊÕÊÓÂʵÄÊý¾Ý?", vbYesNo + vbDefaultButton2) = vbYes Then
L = 0
For Each aTable In .Tables
For Each aCell In aTable.Columns(5).Cells
aCell.Range = myArray(L)
L = L + 1
Next
Next
.PrintOut
End If
End If
.Close False
End With
If TF = True Then WdApp.Quit
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2006-2-14 13:04
发表于 2006-2-14 15:14
楼主