Word (VBA)

Word VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 8 : Word 2013)
ワードに挿仕込み印刷
投稿日時: 18/05/16 16:02:41
投稿者: 2011wing

Excel VBAでご質問です
エクセルからワードに挿し木み印刷ツールを作成しました
訂正前はうまくrunしていましたが訂正後なんらえらーにはならないものの
値が飛んで行かなくなりました。
どなたか訂正方法を宜しくお願い致します
 
訂正前
 
Sub sashikomi_macro()
Dim cmax, cnt, i, k As Long
Dim path, str As String
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdrg As Word.Range
Dim c As Long
Dim waitTime As Variant
 
cmax = Range("A65536").End(xlUp).Row
cnt = Range("IV1").End(xlToLeft).Column
 
Set wdapp = CreateObject("Word.application")
wdapp.Visible = True
 
For i = 2 To cmax
path = ThisWorkbook.path & "\sample.docx"
Set wddoc = wdapp.Documents.Open(path)
waitTime = Now + TimeValue("0:00:03")
Application.Wait waitTime
 
For k = 0 To cnt - 2
With wddoc.Content.Find
.Text = Range("B1").Offset(0, k).Value
.Forward = True
.Replacement.Text = Range("B" & i).Offset(0, k).Value
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With
Next
 
wddoc.PrintOut
 
Next
 
wdapp.Quit
Set wdapp = Nothing
 
End Sub
 
訂正後
 
Sub sashikomi_macro()
Dim lastRow, cnt, i, k As Long
Dim path, str As String
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdrg As Word.Range
Dim c As Long
Dim waitTime As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
 
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = ThisWorkbook.Worksheets(2)
 
lastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
cnt = ws1.Range("IV1").End(xlToLeft).Column
 
Set wdapp = CreateObject("Word.application")
wdapp.Visible = True
 
With ws2
For i = 2 To lastRow
path = ThisWorkbook.path & "\sample.docx"
Set wddoc = wdapp.Documents.Open(path)
waitTime = Now + TimeValue("0:00:03")
Application.Wait waitTime
 
For k = 0 To cnt - 2
With wddoc.Content.Find
.Text = Range("B1").Offset(0, k).Value
.Forward = True
.Replacement.Text = Range("B" & i).Offset(0, k).Value
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With
Next
 
wddoc.PrintOut
 
'str = Range("A" & i).Value & "_" & Range("B" & i).Value & Range("C" & i).Value
'wddoc.SaveAs Filename:=ThisWorkbook.path & "\" & str & ".docx"
'wddoc.Close savechanges:=False
'Set wddoc = Nothing
Next
 
End With
 
wdapp.Quit
Set wdapp = Nothing
 
End Sub
 
 
ws1に元データ ws2に印刷したい企業番号になっております
 
補足
補足です。訂正後はThisWorkbook.Worksheets(1)に元データ一覧があります。ThisWorkbook.Worksheets(2)に入力の
キー番号の値のみループして差し込み印刷したいです。
訂正前はThisWorkbook.Worksheets(1)の全部の値をループ処理して印刷しています
宜しくお願い致します

回答
投稿日時: 18/05/16 17:05:00
投稿者: sk

Excel (VBA) 掲示板 より:
http://www.moug.net/faq/viewtopic.php?t=77106
 
まるっきり同じ内容のスレッドを作成されたようなので
Excel 寄りの回答はそちらに任せて、こちらでは
Word 寄りの回答をしますが、ループ処理で
ワークシートの各行/セルの値を参照して
特定の文字列を置換するのを繰り返すコードを書くより
Word の差込印刷機能を使用された方が簡単なのではないでしょうか。

投稿日時: 18/05/17 15:39:25
投稿者: 2011wing

重複になりますのでこちらを閉じさせて頂きます