Excel (VBA)

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

 
(Windows 8 : Excel 2013)
ワードに差し込み印刷
投稿日時: 18/05/16 16:01:34
投稿者: 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 19:45:44
投稿者: WinArrow
投稿者のウェブサイトに移動

ワークシートの中身、WORD文書の内容が分からないので、
的確なアドバイスが難しい・・・です。
 
 
ステップ実行で、確認してみましょう。

回答
投稿日時: 18/05/16 20:54:29
投稿者: WinArrow
投稿者のウェブサイトに移動

コード記述に関する問題点
 
停止後のコードでは、シートを2つ使用していますが、
シート名で修飾できていないところがあり、
そこが原因ではないかと思います。
 
コードを全文見直して、シート名で修飾することをお勧めします。
 
 

回答
投稿日時: 18/05/17 09:46:03
投稿者: WinArrow
投稿者のウェブサイトに移動

追加レス
 
コードの中の問題点
 
(1)変数のデータ型の定義
>Dim lastRow, cnt, i, k As Long
>Dim path, str As String
 
ここに列挙した変数すべてにデータ型が指定さえていません。
 
例えば、1行目の変数のデータ型に最後の変数で指定している"Long"が適用されると
考えているならば、それは、間違いです。
すべての変数にデータ型を定義するようにしましょう。
プログラム実行に際して、エラーになることはないが、レスポンスに影響します。
 
 
 
(2)シートでの修飾その1
>lastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row

lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
 
間違いではないが、可読性に問題あり
 
 
(3)シートでの修飾その2
>.Text = Range("B1").Offset(0, k).Value
> .Forward = True
> .Replacement.Text = Range("B" & i).Offset(0, k).Value
ここでセルの値を指定しているが、
どちらのシートなのか明示されていません。
 
(4)インデントをキチンとつけましょう。
全体的にインデントがついていません。
可読性が悪く、今後のメンテナンス性に影響します。
 
(5)「差込印刷」という表現について
テッキリWordの「差込印刷」機能を使っているものと早とちりしてしまいましたが、
全く使用していないことが分かりました。
誤解を招く表現は注意しましょう。
とろこで、
データ1件毎にWORD文書を開いているが、効率が悪いと思いませんか?
Wordの「差込印刷」を使用した方が、差込後のファイルを保存することも可能だし
効率もよいと勝手に想像していますが・・・・
 
 

投稿日時: 18/05/17 11:16:45
投稿者: 2011wing

大変丁寧に解説いただきありがとうございます
ご指摘箇所を訂正してみましたが、まだプリントはされるものの
値が飛んで行きません
 
Sub sashikomi_macro()
Dim lastRow As Long, cnt As Long, i As Long, k As Long, c As Long
Dim path As String, str As String
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdrg As Word.Range
Dim waitTime As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook
 
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = ThisWorkbook.Worksheets(2)
   
    lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    cnt = ws1.Range("IV1").End(xlToLeft).Column
 
    Set wdapp = CreateObject("Word.application")
    wdapp.Visible = True
 
    path = ThisWorkbook.path & "\sample.docx"
    Set wddoc = wdapp.Documents.Open(path)
    waitTime = Now + TimeValue("0:00:03")
    Application.Wait waitTime
 
With ws2
    For i = 2 To lastRow
       
            For k = 0 To cnt - 2
            With wddoc.Content.Find
                .Text = ws1.Range("B1").Offset(0, k).Value
                .Forward = True
                .Replacement.Text = ws1.Range("B" & i).Offset(0, k).Value
                .Wrap = wdFindContinue
                .MatchFuzzy = True
                .Execute Replace:=wdReplaceAll
            End With
    Next
 
        wddoc.PrintOut
         
'記入例印刷
Set wb1 = Workbooks.Open(ThisWorkbook.path & "\記入例.xlsx")
Set sh = wb1.Worksheets(1)
sh.PrintOut
               
Next
     
End With
 
    wdapp.Quit
    Set wdapp = Nothing
     
wb1.Close
 
End Sub
 
ws2が企業番号だけのリストなので、ws2の値をws1から探すロジックが必要だとしたら構文は
どんな風にかくのでしょうか
 

回答
投稿日時: 18/05/17 11:29:01
投稿者: WinArrow
投稿者のウェブサイトに移動

ステップ実行は、試されてんですか?
 
変数「i」は、ws2シートの行番号ですよね?
それを
>ws1.Range("B" & i)
のように、ws1の行番号として使用して問題ないのですか?
 
ステップ実行すれば、確認できるはずですが・・・
 
>ws2が企業番号だけのリストなので、ws2の値をws1から探すロジックが必要だとしたら
必要かどうかは、回答者が判断することではないです。
 
 

回答
投稿日時: 18/05/17 13:03:21
投稿者: もこな2

ものすごい偶然が起こってるだけかもしれないが、
http://www.excel.studio-kazu.jp/kw/20180516160559.html
こちらでも、見た感じ同じ内容のコードがアップされ質問トピックが立ち上がってます。
 
別の方であればいいんですが、同じ方であれば、このような行為は「マルチポスト」と呼ばれ、掲示板によっては禁止しているところもあります。
 
また、この掲示板の規約ではマルチポストを禁止していないので、ダメとはいわないですが、それでも人によっては不快に思う場合もあるので、どうしてもマルチポストしたいなら、一言、別掲示板でも聞いてます。
くらいは書き添えておいた方がいいとおもいます。

投稿日時: 18/05/17 13:54:54
投稿者: 2011wing

WinArrow さんの引用:
ステップ実行は、試されてんですか?
 
変数「i」は、ws2シートの行番号ですよね?
それを
>ws1.Range("B" & i)
のように、ws1の行番号として使用して問題ないのですか?
 
ステップ実行すれば、確認できるはずですが・・・
 
>ws2が企業番号だけのリストなので、ws2の値をws1から探すロジックが必要だとしたら
必要かどうかは、回答者が判断することではないです。
 
 

 
 
ステップ実行したところ i=0,K=0 なので値が飛んでいかないのかと。。。。。
WS2の i とws1を紐付けるにはどうしたら良いのでしょうか?
 
 
ps、他のトピでも同様の質問を投稿しております

回答
投稿日時: 18/05/17 14:19:25
投稿者: WinArrow
投稿者のウェブサイトに移動

>ps、他のトピでも同様の質問を投稿しております
 
そうですか・・・・それならば、どちらかを閉じましょう。
 

2011wing さんの引用:

ステップ実行したところ i=0,K=0 なので値が飛んでいかないのかと。。。。。
WS2の i とws1を紐付けるにはどうしたら良いのでしょうか?
 

ステップ実行の結果は、どこに時点の値ですか?
少なくとも[i]は2から始まっているので「i=0」はあり得ない。
 
ws2はどのような目的で追加したのですか?
Ws1とws2の関係も不明
ws1とws2のレイアウトも不明
 
回答者にはあなたのPCの画面は見えません。
文章で説明するには、難しいかもしれませんが、
回答者に見えるようにしないと、的確なアドバイスが貰えません。
このような状況では回答不能です。
 
 
 
 
 
 
 

回答
投稿日時: 18/05/17 14:43:01
投稿者: WinArrow
投稿者のウェブサイトに移動

修正後のコードをよくみたら
WODR文書を開く場所を、1回目のループ(For i = 2 To Lastrow)の外に出してしまいましたね・・・
 
最初の訂正前の思想と変わってしまうが問題ないのかな?
 
このような思想変更は、現在抱えている問題解決してからでよいと思うが・・・
あちこち手を入れると問題の本質が見えなくなってしまいますよ!
 

投稿日時: 18/05/17 14:49:13
投稿者: 2011wing

WinArrow さんの引用:
修正後のコードをよくみたら
WODR文書を開く場所を、1回目のループ(For i = 2 To Lastrow)の外に出してしまいましたね・・・
 
最初の訂正前の思想と変わってしまうが問題ないのかな?
 
このような思想変更は、現在抱えている問題解決してからでよいと思うが・・・
あちこち手を入れると問題の本質が見えなくなってしまいますよ!
 

データ1件毎にWORD文書を開いているが、効率が悪いと思いませんか?
 
とのコメントいただいたので修正したつもりだったのですが…

投稿日時: 18/05/17 16:05:19
投稿者: 2011wing

ws2のシート構成はいかになります
 
A列
企業コード
 
001
007
003
 
 
ws1のシート構成は
 
A列 B列 C列 D列
企業コード 企業名 住所 郵便番号
001 鈴木商事 千葉県 111000
002 田中商事 東京都 1230088
003 佐藤商事 埼玉県 3339999
007 近藤商事 埼玉県 5556666
 
以下のようになります
どうぞよろしくお願いします
 
 
 

回答
投稿日時: 18/05/17 16:16:12
投稿者: WinArrow
投稿者のウェブサイトに移動

>データ1件毎にWORD文書を開いているが、効率が悪いと思いませんか?
  
とコメントしたことは間違いないのですが、最初の思想まで変更してしまうと
元も子もなくなってしまいます。
 
レイアウトは、分かりましたが、
なぜws2を追加したんですか?
ws1とws2の関係が不明
つまり、ws2の企業コードに対してws1の企業コードが「1:1」の関係ならば、
敢えて、ws2を追加する意味がない。
ということです。
 
もう一つ
WORDの「差込印刷」機能をなぜ使わないのですか?
自分でループ処理で悩むこともない。

投稿日時: 18/05/17 16:30:10
投稿者: 2011wing

すみません ファイルオープンはループの外に記載するのがいいのかとおもいましたが
どこに記載するのが適切でしょうか
 
ws1は全企業明細
 
ws2は抽出企業になります
 
 
ワードの差込印刷にしないわけは
このコードの後にエクセルでいろんな集計情報とか(企業ごとの)
が自動で集計し印刷できるようにせってしてあります
頭紙のみワードになっているので
 
ワードの差込印刷で済むのならそもそも質問しないと思います
手動では無理な件数があります

回答
投稿日時: 18/05/17 16:33:30
投稿者: WinArrow
投稿者のウェブサイトに移動

WEBで紹介されているコードをそのままコピペすることは悪いことではないが、
どんな場合でも適用できるということはありません。
あくまでもサンプルです。
 
データの持ち方など環境によって、適用条件が違うので、
何処がサンプルと異なるかをじっくり精査しないと、後手後手になってしまいます。
異なる部分が明確になったうえでカスタマイズすることになります。
 
今回の質問は、
異なる部分が明確なっていない状態で、
カスタマイズ部分だけ、他人にお願いする形になっています。
勿論、コードそのものの意味も理解しているとは思えない。
 
以上、感想です。

回答
投稿日時: 18/05/17 17:39:57
投稿者: sk

引用:
ws2のシート構成はいかになります
  
A列
企業コード
  
001
007
003
  
  
ws1のシート構成は
  
A列 B列 C列 D列
企業コード 企業名 住所 郵便番号
001 鈴木商事 千葉県 111000
002 田中商事 東京都 1230088
003 佐藤商事 埼玉県 3339999
007 近藤商事 埼玉県 5556666

Sub sashikomi_macro()
 
    Dim cmax As Long
    Dim cnt As Long
    Dim i As Long
    Dim k As Long
    Dim path As String
    Dim wdapp As Word.Application
    Dim wddoc As Word.Document
    Dim ws1 As Excel.Worksheet
    Dim ws2 As Excel.Worksheet
    Dim found As Excel.Range
    Dim getrow As Long
    Dim printed As Long
      
    With ThisWorkbook
        Set ws1 = .Worksheets(1)
        Set ws2 = .Worksheets(2)
    End With
     
    cnt = ws1.Range("IV1").End(xlToLeft).Column
    cmax = ws2.Range("A65536").End(xlUp).Row
      
    If cmax < 2 Then
        MsgBox "[" & ws2.Name & "]にキー番号が入力されていません。"
        Exit Sub
    End If
     
    Set wdapp = CreateObject("Word.application")
    wdapp.Visible = True
      
    path = ThisWorkbook.path & "\sample.docx"
      
    For i = 2 To cmax
         
        Set found = ws1.Columns(1).Find(What:=ws2.Cells(i, 1).Text, _
                                        LookAt:=xlWhole)
        If Not found Is Nothing Then
                     
            getrow = found.Row
         
            Set wddoc = wdapp.Documents.Open(path)
              
            For k = 2 To cnt
                With wddoc.Content.Find
                    .Text = ws1.Cells(1, k).Text
                    .Forward = True
                    .Replacement.Text = ws1.Cells(getrow, k).Text
                    .Wrap = wdFindContinue
                    .MatchFuzzy = True
                    .Execute Replace:=wdReplaceAll
                End With
            Next
              
            wddoc.PrintOut
            wddoc.Close False
             
            printed = printed + 1
             
        End If
    Next
      
    wdapp.Quit
    Set wdapp = Nothing
     
    If printed = 0 Then
        MsgBox "印刷されたデータはありません。"
    Else
        MsgBox printed & " 件のデータを印刷しました。"
    End If
 
End Sub
------------------------------------------------------------------------------
 
恐らくこんな感じかと。
 
引用:
ワードの差込印刷にしないわけは
このコードの後にエクセルでいろんな集計情報とか(企業ごとの)
が自動で集計し印刷できるようにせってしてあります
頭紙のみワードになっているので

(ここでの集計/印刷処理の詳細が不明ですが)
どちらかに統一すればいいのに、というのが率直な印象。

回答
投稿日時: 18/05/17 18:07:51
投稿者: WinArrow
投稿者のウェブサイトに移動

 
 
 
変数を分かりやすい名前に変更してあります。
  
参考コード
  
     Set ws1 = ThisWorkbook.Worksheets(1)
     Set ws2 = ThisWorkbook.Worksheets(2)
   
     LastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
     cnt = ws1.Range("IV1").End(xlToLeft).Column
   
     Set wdapp = CreateObject("Word.application")
     wdapp.Visible = True
   
     With ws2
         For ws2Row = 2 To LastRow
             If WorksheetFunction.CountIf(ws1.Columns("A"), .Cells(ws2Row, "A").Value) > 0 Then
                 ws1Row = WorksheetFunction.Match(.Cells(ws2Row, "A").Value, ws1.Columns("A"), 0)
                 Set wddoc = wdapp.Documents.Add(Template:=ThisWorkbook.path & "\sample.docx")
                 Application.Wait Now + TimeValue("0:00:03")
                 For ws1COL = 0 To cnt - 2
                     With wddoc.Content.Find
                         .Text = ws1.Range("B1").Offset(0, ws1COL).Value
                         .Forward = True
                         .Replacement.Text = ws1.Range("B" & ws1Row).Offset(0, ws1COL).Value
                         .Wrap = wdFindContinue
                         .MatchFuzzy = True
                         .Execute Replace:=wdReplaceAll
                     End With
                 Next
   
                 wddoc.PrintOut
                 wddoc.Close False
             Else
                 MsgBox "「" & ws2.Name & "」の企業コード=" & .Cells(ws2Row, "A").Value & "が" & _
                         "「" & ws1.Name & "」に存在しません。"
             End If
         Next
     End With
 

投稿日時: 18/05/17 19:11:11
投稿者: 2011wing

sk様
WinArrow様
 
両名とも無事にRUNしております
本当に助かりました
 
これからいただいた構文の理解に入らさせていただきます
 
また理解しやすいように配慮いただい本当に感謝しております
ありがとうございました