[[20170313130335]]　『マクロで配置』（関数がにがて）　ページの最後に飛ぶ

『マクロで配置』（関数がにがて）

いつもお世話になっております。
またお知恵をお借りしたいです。

仕事で荷物のやり取りを社内メール便で行っていて、通い袋の宛先表を作成しています。
印刷シートにA4両面印刷で1枚に最大3ヶ所分の印刷ができるように配置して印刷しています。

 　 A  B  C  D  E  F  G  H  I  J  K
  1    __________________________ 
  2   |       相手の会社名       |
  3   |       　　部署名   　　  |
  4   |      担当者名  様        |
 :　　|            ↑            |
 15   |      こちらの会社名      |
 16   |__________部署名__________|
 17   |__________________________|
 18
 :					
 :
 :
 85    __________________________
 86   |       こちらの会社名     |
 87   |           部署名  　　   |
 88   |           担当名         |
 :    |             ↑           |
 96   |      相手の会社名        |
 97   |           部署名         |
 98   |__________________________|
 99

線は罫線で引いてあります。
行数を省略したので大まかですが、このような配置の印刷シートを作成し、メール宛先シートには

 　 A      B      C     D     E
 1　No  会社名　部署　担当　備考
 2  1    ○○　 ××  伊藤
 3  2　　△△　 ◇◇  安藤　4587
 :　:　　　:　　　:　　:　　　:
発行する宛先を入力してあります。（備考欄は入っている所とない所があります）
こちらの会社名などは変化ないので、印刷シートにそのまま入れてあり
下のマクロを組み1枚づつシートを作成しております。

Sub メール表発行()

    Dim 数 As Long
    For 数 = 2 To Worksheets("メール宛先").Range("A2").End(xlDown)
    If Worksheets("メール宛先").Cells(数, 2).Value = "" Then Exit For

        Dim 宛名 As String
        宛名 = Worksheets("メール宛先").Cells(数, 4).Value
        Dim 会社名 As String
        会社名 = Worksheets("メール宛先").Cells(数, 2).Value
        Dim 宛先 As String
        宛先 = Worksheets("メール宛先").Cells(数, 3).Value
        Dim 備考 As Variant
        備考 = Worksheets("メール宛先").Cells(数, 5).Value

            Worksheets("印刷シート").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = 宛名
            With Worksheets(宛名)
                .Range("F5").Value = 会社名
                .Range("F7").Value = 宛先
                .Range("F9").Value = 宛名
                .Range("F95").Value = 会社名
                .Range("F97").Value = 宛先
                .Range("J98").Value = 備考
            End With

    Next

    MsgBox "メール表の発行が完了しました。"

End Sub

そして作成されたシートをコピペし、1枚に3社分の宛先表を配置して印刷しています。
2枚目のこちらからの表は19行目に戻ってくるのは71行目に貼り付け、
3枚目のこちらからの表は37行名に戻ってくるのは55行目に貼り付けています。
これを自動配置できないでしょうか？
頻繁に部署名変更や担当者が変更になり、大量に印刷する時に手間になっています。

どうぞよろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 >これを自動配置できないでしょうか？

 もちろん可能でしょう。

 ただ、もう少し仕様と要件を明確にしてください。

 まず、仕様ですけど、印刷シートのレイアウトってアップされたように、上のほうとしたのほうに
 １宛先分のみの罫線ブロックがあるんですか？

 最終の　４枚組のできあがりレイアウトがよくわかりません。

 >そして作成されたシートをコピペし、1枚に3社分の宛先表を配置して印刷しています。 
 >2枚目のこちらからの表は19行目に戻ってくるのは71行目に貼り付け、 
 >3枚目のこちらからの表は37行名に戻ってくるのは55行目に貼り付けています。

 この文章の意味が、理解できません。（特に　戻ってくる　という言葉）

 で、要件なんですけど、今は、メール宛先シートの各データに対して、それぞれ１枚、新規シートをつくって
 そこの転記してますよね。
 これは必要なのですか？

 それとも、４枚１組のシートができ上れば、それでいいのですか？

 さらに、新規シートはつくらず、印刷シートに配置して印刷、配置して印刷、・・・　ということができればいいのですか？

（β） 2017/03/13(月) 14:36

βさん、説明不足で申し訳ありません。

印刷シートのレイアウトは両面印刷でちょうど裏表になるように
配置されているので、上のほうと下のほうに1宛先分の罫線ブロックがあります。

最終はA4　1枚に3宛先分の両面コピーができることになります。
なので

 >>そして作成されたシートをコピペし、1枚に3社分の宛先表を配置して印刷しています。 
 >>2枚目のこちらからの表は19行目に戻ってくるのは71行目に貼り付け、 
 >>3枚目のこちらからの表は37行名に戻ってくるのは55行目に貼り付けています。 
と言う説明がわかりずらかったと思いますが、
1社目のシートに2・3社目をコピペして、両面コピーで1枚になります。
1～18行目が1社目、19行目には2社目のシートの1～18行目、37行目には3社目の1～18行目が配置され、
55行目には3社目の85～99行目が、71行目には2社目の85～99行目が、85行目～99行目には1社目が配置されることになります。

 >で、要件なんですけど、今は、メール宛先シートの各データに対して、それぞれ１枚、新規シートをつくって
 > そこの転記してますよね。
 >これは必要なのですか？
今の私の技量ではこの方法しかできなかったのです。
出来るのならば、新規シートに配置して印刷、配置して印刷、・・・がしたいです。

よろしくお願いします。
（関数がにがて） 2017/03/13(月) 15:18

 理解が足りないところもあるかもしれませんが、たたき台です。

 ●印刷シートは、３社分の罫線フォーマットにしておいてください。

 ３社１組にして新規シートを作成します。
 新規シートを作成せず、直接印刷ということも可能ですが、たとえばメール宛先シートのどこかに間違いがあって
 そこを直して再実行すると、間違っていなかったページも、再度印刷されますので　新規シートとしました。

 最後のシート、１社分しかない、２社分しかない　といったケースがあるわけで、その場合、罫線などがあると
 無駄なラベルが印刷されてしまう　といった不満はあるかもしれませんんが、そこは、最後になんとでもなりますので。

 また、新規作成したシートを自動印刷したい、印刷したシートを削除したいということもあるとは思いますが、
 そこも、最後になんとでも。

 ★なお、明日から１週間ほど、旅に出ます。その間、フォローできないと思います。

Sub メール表発行2()

    Const UPPER As Long = 18
    Const LOWER As Long = -15
    Dim 数 As Long
    Dim cnt As Long
    Dim psh As Worksheet
    Dim 宛名 As String
    Dim 会社名 As String
    Dim 宛先 As String
    Dim 備考 As Variant

    With Worksheets("メール宛先")

        For 数 = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            cnt = cnt + 1
            If cnt > 3 Then cnt = 1
            If cnt = 1 Then
                Worksheets("印刷シート").Copy after:=Worksheets(Worksheets.Count)
                Set psh = ActiveSheet
            End If

            宛名 = .Cells(数, 4).Value
            会社名 = .Cells(数, 2).Value
            宛先 = .Cells(数, 3).Value
            備考 = .Cells(数, 5).Value

            With psh

                .Range("F5").Offset((cnt - 1) * UPPER).Value = 会社名
                .Range("F7").Offset((cnt - 1) * UPPER).Value = 宛先
                .Range("F9").Offset((cnt - 1) * UPPER).Value = 宛名

                .Range("F95").Offset((cnt - 1) * LOWER).Value = 会社名
                .Range("F97").Offset((cnt - 1) * LOWER).Value = 宛先
                .Range("J98").Offset((cnt - 1) * LOWER).Value = 備考

            End With
        Next

    End With

End Sub

（β） 2017/03/13(月) 20:38

βさん、ありがとうございます。
思った通りにできました。

 >   Const UPPER As Long = 18
 >   Const LOWER As Long = -15
が割り振りを決めているのでしょうか？
内容をじっくり勉強します。

本当にありがとうございました。
（関数がにがて） 2017/03/14(火) 15:17

コメント返信：

[ 一覧(最新更新順) ]

[[20170313130335]] 『マクロで配置』（関数がにがて） ページの最後に飛ぶ

[[20170313130335]]　『マクロで配置』（関数がにがて）　ページの最後に飛ぶ