返品依頼テンプレートを出版社別に複製しデータを流し込む

henpitempdataeyecatcha

返品依頼テンプレートを複製し、出版社毎に自動でデータの流し込みを行います。
また同時にFAX電話帳BOOKのデータも参照し、作成している返品依頼表に転記します。

こんにちは、じゅんぱ店長（@junpa33）です。

今回は,

エクセルBOOK「返品了解申請.xlsm」の「返品本分類」シートの返品書誌データから、複製したテンプレートへデータを移し、返品依頼書を作成します。

その前に、

前回の記事の確認をするにはこちら↓からお読みいただけます。

henjyocleyecatcha 利用後データのクリアコードの組み立て方。返品了解書作成

返品依頼テンプレートへのデータ流し込みの進め方

henpinsinsaku006

以前の回に、エクセルBOOK「返品了解申.xlsm」に返品依頼テンプレートを作成しました。

今回は、そのテンプレートにVBAを使って複製コピーとデータ入力して、実際に使えるものにしていきます。

  1. 　返品依頼テンプレートを出版社別に複製していきます。
  2. 　前回作業で「返品本依頼」シートに流し込んだデータを出版社別のテンプレートに配置していきます。
  3. 　送信先出版社の電話番号・ＦＡＸ番号・メールアドレスを電話帳より検索し、送信する用紙に表示します。

出版社別の返品依頼テンプレートはその都度、返品対象の出版社分をコピー作成しますので、その時々で枚数が異なります。

返品理由については、空欄部分にその都度手書きか手打ちで書き込むようになります。

同時にＦＡＸ番号も表示させます。（ただし、事前に電話帳登録が必要です。）

目次へ戻る

流し込みVBAコードの作成

henpinsinsaku007

初めに、「返品了解申.xlsm」に標準モジュールを挿入します。

（挿入の方法はこちら↓で確認できます。）

「ＶＢＥ（ビジュアルベーシックエディター）を起動する」

vbavbekidoeyecatch VBA初めての起動。VBEの立ち上げ、保存と終了

テンプレートの複製コードの作成

出版社別に返品依頼書シートを、テンプレートの複製で作っていきます。

シート名は、「ページＮＯ．」で表示するようにします。

プロシージャー名を「テンプレコピー」とします。

VBA
Sub テンプレコピー()
・・・・ 
End Sub

このプロシージャーでの変数はこのようになります。

  1. 　「返品本分類のデータ行数」・・・・・BRow
  2. 　「複製するシートのページＮＯ．」・・SN
  3. 　「ループ処理のループ回数」・・・・・i

A列の値（ページ番号）を上から順番に上下段２行づつ比較して、

値が同じならばスルー、

値が違えばその値をシート名としてテンプレートを複製します。

これをループしていきます。

関連記事

VBAGotoeyecatch001 Gotoステートメントでコードをジャンプ！毒と薬の2面性 vbalastcelleyecatch データ入力済セルの最終行番号を取得する VBACopyeyecatch シートのコピーを最速に理解！VBAコードで異なる結果
VBA
Option Explicit

Sub テンプレコピー()
    Dim SN As Variant
    Dim BRow As Long
    Dim i As Long
        Worksheets("返品本分類").Select
        BRow = Cells(Rows.Count, 1).End(xlUp).Row
        If BRow <= 1 Then
          MsgBox "作成するテンプレートのデータはありません。"
          Exit Sub
        End If
        For i = 1 To BRow
            SN = Range("A" & i).Value
            If i = 1 Then GoTo step1
            If SN = Range("A" & i - 1).Value Then GoTo step2
step1:
            Worksheets("返品依頼テンプレート").Select
            Worksheets("返品依頼テンプレート").Copy _
                        after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = SN
step2:
            Worksheets("返品本分類").Select
        Next i
End Sub

データの適所配置のコードの作成

つぎに「返品本分類」シートにあるそれぞれのデータを、

出版社ごと（ページ番号）ごとに複製したテンプレートにはめ込んでいきます。

プロシージャー名を「データ移動」とします。

VBA
Sub データ移動() 
・・・・
End Sub

このプロシージャーでの変数はこのようにします。

  1. 　「返品本分類のデータ行数」・・・・・BRow
  2. 　「複製するシートのページＮＯ．」・・SN
  3. 　「ループ処理のループ回数」・・・・・ｐ、ｓ
  4. 　「ＩＳＢＮ」・・・・・・・・・・・・ISBN
  5. 　「書名」・・・・・・・・・・・・・・SHO
  6. 　「出版社名」・・・・・・・・・・・・SYU
  7. 　「著者名」・・・・・・・・・・・・・TYO
  8. 　「本体価格」・・・・・・・・・・・・PRI
  9. 　「返品冊数」・・・・・・・・・・・・HSA
  10. 　「客注名」・・・・・・・・・・・・・KYA

「返品本分類」シートでは、出版社別リストごとに項目名行を挟み込んでいますので、

この「返品本分類」の一覧リストからデータを順番に収集するときに項目行をスルーする必要があります。

ループ処理でこの「項目名」を拾ったときは「GoTo　Step」で処理をスルーして次のループに移るようにします。

テンプレート内には、

「著者名」と「本体価格」の表示する部分を作っていませんが、欄外に表示するようにしています。

「本体価格」表示列の下部行に返品金額の本体合計を計算できるようにしています。

（ただしこれは、「返品本分類」シート上で、本体価格が数値か金額で表示されている必要があります。）

プリントエリアを設定しています。

この欄外の表示部分はプリントされない仕様です。返品事由記入の参考項目としています。

vbasheetvariableeyecatch ワークシートを変数化する3つの手法 オブジェクト変数など fornextirekoeyecatch For～Nextのループと入れ子構造をVBA最速理解 vbasumeyecatch SUM関数で合計計算！実務で使えるVBAコード作成 vbacellsfonteyecatch 「フォント」の操作を最速理解する エクセルVBA vbacolumnseyecatch Columnsプロパティでセルの列を指定する
VBA
Sub データ移動()
    Dim SN As Variant
    Dim BRow, HSA, p, s As Long
    Dim ISBN, PRI, KYA As Variant
    Dim SHO, SYU, TYO As String
        Worksheets("返品本分類").Select
        BRow = Cells(Rows.Count, 1).End(xlUp).Row
        For s = 1 To BRow
            Worksheets("返品本分類").Select
            SN = Range("A" & s)
            If Range("B" & s) = "ＩＳＢＮ" Then GoTo step3
            ISBN = Range("B" & s).Value
            SHO = Range("C" & s).Value
            SYU = Range("D" & s).Value
            TYO = Range("E" & s).Value
            PRI = Range("F" & s).Value
            HSA = Range("G" & s).Value
            KYA = Range("H" & s).Value
            Worksheets(SN).Select
            Range("B2").Value = SYU
            Range("C40").Value = SYU
            Range("C66").Value = SYU
            For p = 1 To 13
                If Range("C" & 10 + p) = "" Then
                    Range("B" & 10 + p).Value = ISBN
                    Range("C" & 10 + p).Value = SHO
                    Range("D" & 10 + p).Value = HSA
                    Range("B" & 44 + p).Value = ISBN
                    Range("C" & 44 + p).Value = SHO
                    Range("D" & 44 + p).Value = HSA
                    Range("E" & 44 + p).Value = KYA
                    Range("G" & 44 + p).Value = TYO
                    Range("H" & 44 + p).Value = PRI
                    Range("B" & 70 + p).Value = ISBN
                    Range("C" & 70 + p).Value = SHO
                    Range("D" & 70 + p).Value = HSA
                    Range("E" & 70 + p).Value = KYA
                    Range("G" & 70 + p).Value = TYO
                    Range("H" & 70 + p).Value = PRI
                    Exit For
                End If
            Next p
            Range("H58").Value = "本体合計￥" _
                & WorksheetFunction.Sum(Range("H45:H57"))
            Range("H84").Value = "本体合計￥" _
                & WorksheetFunction.Sum(Range("H71:H83"))
            Range("B2").Font.Size = 16
            Range("B45:E57").Font.Size = 10
            Range("B71:E83").Font.Size = 10
            Worksheets(SN).PageSetup.PrintArea = "A1:F86"
            Columns("G:H").AutoFit
step3:
        Next s
End Sub

送信先電話番号の表示

出版社から返品了解を取る業務の中で、返品依頼を作成する作業は結構大変ですが、

その作業の中でも地味に面倒なのが、送信先の電話番号を調べるという作業です。

ですので、これも自動化してしまいましょう。

汎用性のある電話帳をエクセルで作成します。ここにはVBAを埋め込みませんので、

「FAX電話帳.xlsx」、使用するシート名を「電話番号」としてください。

Ａ、Ｂ，Ｃ，Ｄ列の項目はこの通りです。

henpinsinsaku001a

準備が出来ましたら、

エクセルBOOK「返品了解申請.xlsm」で、先ほどに続いてVBAを組み立てていきます。

電話帳からデータを収集するために「返品了解申請.xlsm」から、VBAコードで「FAX電話帳.xlsx」を開きます。

すでに開いている場合は、この作業はスルーされます。

プロシージャー名を「FAX電話OPEN」とします。

vbachdireyecatch ChDirステートメントでカレントフォルダを簡単に変更する vbadoloopeyecatch VBA 回数不定のループ処理はDo LoopとFor Each
VBA
Sub FAX電話OPEN()
    Dim flag As Boolean
    Dim Wb As Workbook
    Dim FAX As String
        ChDir ThisWorkbook.Path
        FAX = ThisWorkbook.Path & "\FAX電話帳.xlsx"
        flag = False
        For Each Wb In Workbooks
            If Wb.FullName = FAX Then
                flag = True
                Exit For
            End If
        Next
        If flag = False Then
            Workbooks.Open FAX, UpdateLinks:=0
        End If
End Sub

「FAX電話帳.xlsx」を開いたところで、調べたい出版社名の電話番号を探しに行きます。

方法としては、

「返品了解申請.xlsx」の出版社別に作成したシートの宛先から出版社名を拾います。

それと、「FAX電話帳.xlsx」の「電話番号」シート内のデータと比較するということにします。

ワークシート関数の「Match」を使いますが照合できないとエラーが出ますので、そのエラーを無視やスルーする処理コードが必要となります。

vbamatcheyecatch001 VBAで使うMatch関数 活用度アップでテッパン関数に！ fornextirekoeyecatch For～Nextのループと入れ子構造をVBA最速理解 vbainsteeyecatch Instr関数・InstrRev関数は文字列を検索する。ファイルパス取得に威力 vbacalleyecatch 部品化プロシージャーでCallステートメントは必須

Ｓｕｂプロシージャー名を「電話番号検索」とします。

VBA
Sub 電話番号検索()
    Dim i As Long
    Dim ASN As Variant
    Dim SYU As Variant
    Dim DR As Long
    Dim tela, telb, telc As Variant
        Workbooks("返品了解申請.xlsm").Activate
        For i = 1 To Worksheets.Count
            ASN = Worksheets(i).Name
            If InStr(ASN, "Ｐ") > 0 Then
                Worksheets(ASN).Select
                SYU = Range("B2").Value
                Call Module1.FAX電話OPEN
                Workbooks("FAX電話帳.xlsx").Activate
                Worksheets("電話番号").Select
                On Error Resume Next
                DR = WorksheetFunction.Match(SYU, Worksheets("電話番号") _
                            .Columns("A"), 0)
                On Error GoTo 0
                If DR <> 0 Then
                    tela = Range("B" & DR)
                    telb = Range("C" & DR)
                    telc = Range("D" & DR)
                    Workbooks("返品了解申請.xlsm").Activate
                    Worksheets(ASN).Select
                    Range("E3") = "FAX　" & tela
                    Range("E4") = "TEL　" & telb
                    Range("E5") = "MAIL" & telc
                    Range("E3:E5").Font.Size = 10
                End If
            End If
            Workbooks("返品了解申請.xlsm").Activate
        Next i
        Workbooks("FAX電話帳.xlsx").Close False
End Sub

このような感じです。

目次へ戻る

今回作成したVBA全コード

henpinsinsaku007

今回作成したコードはこのような感じです。

VBA
Option Explicit

Sub テンプレコピー()
    Dim SN As Variant
    Dim BRow As Long
    Dim i As Long
        Worksheets("返品本分類").Select
        BRow = Cells(Rows.Count, 1).End(xlUp).Row
        If BRow <= 1 Then
          MsgBox "作成するテンプレートのデータはありません。"
          Exit Sub
        End If
        For i = 1 To BRow
            SN = Range("A" & i).Value
            If i = 1 Then GoTo step1
            If SN = Range("A" & i - 1).Value Then GoTo step2
step1:
            Worksheets("返品依頼テンプレート").Select
            Worksheets("返品依頼テンプレート").Copy _
                        after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = SN
step2:
            Worksheets("返品本分類").Select
        Next i
End Sub

Sub データ移動()
    Dim SN As Variant
    Dim BRow, HSA, p, s As Long
    Dim ISBN, PRI, KYA As Variant
    Dim SHO, SYU, TYO As String
        Worksheets("返品本分類").Select
        BRow = Cells(Rows.Count, 1).End(xlUp).Row
        For s = 1 To BRow
            Worksheets("返品本分類").Select
            SN = Range("A" & s)
            If Range("B" & s) = "ＩＳＢＮ" Then GoTo step3
            ISBN = Range("B" & s).Value
            SHO = Range("C" & s).Value
            SYU = Range("D" & s).Value
            TYO = Range("E" & s).Value
            PRI = Range("F" & s).Value
            HSA = Range("G" & s).Value
            KYA = Range("H" & s).Value
            Worksheets(SN).Select
            Range("B2").Value = SYU
            Range("C40").Value = SYU
            Range("C66").Value = SYU
            For p = 1 To 13
                If Range("C" & 10 + p) = "" Then
                    Range("B" & 10 + p).Value = ISBN
                    Range("C" & 10 + p).Value = SHO
                    Range("D" & 10 + p).Value = HSA
                    Range("B" & 44 + p).Value = ISBN
                    Range("C" & 44 + p).Value = SHO
                    Range("D" & 44 + p).Value = HSA
                    Range("E" & 44 + p).Value = KYA
                    Range("G" & 44 + p).Value = TYO
                    Range("H" & 44 + p).Value = PRI
                    Range("B" & 70 + p).Value = ISBN
                    Range("C" & 70 + p).Value = SHO
                    Range("D" & 70 + p).Value = HSA
                    Range("E" & 70 + p).Value = KYA
                    Range("G" & 70 + p).Value = TYO
                    Range("H" & 70 + p).Value = PRI
                    Exit For
                End If
            Next p
            Range("H58").Value = "本体合計￥" _
                & WorksheetFunction.Sum(Range("H45:H57"))
            Range("H84").Value = "本体合計￥" _
                & WorksheetFunction.Sum(Range("H71:H83"))
            Range("B2").Font.Size = 16
            Range("B45:E57").Font.Size = 10
            Range("B71:E83").Font.Size = 10
            Worksheets(SN).PageSetup.PrintArea = "A1:F86"
            Columns("G:H").AutoFit
step3:
        Next s
End Sub

Sub 電話番号検索()
    Dim i As Long
    Dim ASN As Variant
    Dim SYU As Variant
    Dim DR As Long
    Dim tela, telb, telc As Variant
        Workbooks("返品了解申請.xlsm").Activate
        For i = 1 To Worksheets.Count
            ASN = Worksheets(i).Name
            If InStr(ASN, "Ｐ") > 0 Then
                Worksheets(ASN).Select
                SYU = Range("B2").Value
                Call Module1.FAX電話OPEN
                Workbooks("FAX電話帳.xlsx").Activate
                Worksheets("電話番号").Select
                On Error Resume Next
                DR = WorksheetFunction.Match(SYU, Worksheets("電話番号") _
                            .Columns("A"), 0)
                On Error GoTo 0
                If DR <> 0 Then
                    tela = Range("B" & DR)
                    telb = Range("C" & DR)
                    telc = Range("D" & DR)
                    Workbooks("返品了解申請.xlsm").Activate
                    Worksheets(ASN).Select
                    Range("E3") = "FAX　" & tela
                    Range("E4") = "TEL　" & telb
                    Range("E5") = "MAIL" & telc
                    Range("E3:E5").Font.Size = 10
                End If
            End If
            Workbooks("返品了解申請.xlsm").Activate
        Next i
        Workbooks("FAX電話帳.xlsx").Close False
End Sub

Sub FAX電話OPEN()
    Dim flag As Boolean
    Dim Wb As Workbook
    Dim FAX As String
        ChDir ThisWorkbook.Path
        FAX = ThisWorkbook.Path & "\FAX電話帳.xlsx"
        flag = False
        For Each Wb In Workbooks
            If Wb.FullName = FAX Then
                flag = True
                Exit For
            End If
        Next
        If flag = False Then
            Workbooks.Open FAX, UpdateLinks:=0
        End If
End Sub
目次へ戻る

データ流し込みコード作成のまとめ

henpinsinsaku009

今回作成したVBAは、作成した返品依頼テンプレートを複製して、

出版社毎に返品書誌データをはめ込むところまで完了させました。

次回は、送信元の情報を表示できるようにします。

番線印も表示できるようにします。

次の記事を読むのはこちら↓です。

henpihashineyecatchaa 返品元情報を表示するVBAコード。返品依頼書作成

エクセルVBAを独習するのに参考書は欠かせません。 参考書選びは自分に合った「相棒」にできるものを選んでいきたいです。

vbastudyeyecatch2 エクセルVBAの独習でおすすめ参考書を7冊選ぶ。良書との出会いは大切です

今回の記事はここまでです。   最後までご覧いただき有難うございました。

エクセルVBA最速理解で必要な知識を集めよう！

エクセルVBA業務ツールで日常の業務改善を行いましょう。

＜記事内容についての告知＞

VBAコードの記述記事においては、その記述には細心の注意をしたつもりですが、掲載のVBAコードは動作を保証するものではりません。 あくまでVBAの情報の一例として掲載しています。 掲載のVBAコードのご使用は、自己責任でご判断ください。 万一データ破損等の損害が発生しても当方では責任は負いません。

目次へ戻る

アンケートでポイ活しよう!!

アンケートに答えれば答えるほど ”使える” ポイントがたまります。

NTTコム サーチ

af_banner01

Dstyle web

dstyleweb_logo
dstyle_320x50-min

前の記事

henjyocleyecatcha
利用後データのクリアコードの組み立て方。返品了解書作成

次の記事

返品元情報を表示するVBAコード。返品依頼書作成
henpihashineyecatchaa