データのあるブックから別のエクセルに値を転送するVBA

datarenkeyecatch

出版社リストにあるデータを、テンプレート用エクセルブックに転送するコードを作成します。
転送先のエクセルシートで、さらに付随データをまとめて一覧表にします。

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

今回は,

返品了解書作成ソフト作りの中で、先回に作成した各出版社名シートのデータを

以前に作成したエクセルBOOK「返品了解申請.xlsm」に移す、VBAプログラム作りを行います。

抽出した書誌データを返品了解書のテンプレートへ転記するための準備作業の後半部分になります。

先回の返品了解書作成記事はこちら↓からお読みいただけます。

syosikakoueyecatcha 返品書誌データを出版社別に振り分けた出版社シートの作成

返品了解書の作成　この記事での説明部分

tensorenp005

先回に作成した、各出版社ごとの書誌データを「返品了解申請.xlsm」に落としこみます。

作業の流れとしては、エクセルBOOK「返品書誌情報.xlsm」からのVBAコードで

①「返品了解申請.xlsm」を開きます。（すでに開かれているときはスルー）

②「返品了解申請.xlsm」の「返品本分類」シートに作成リストとしてデータ転記します。

このタイミングで、転送前のデータのチェックや修正を出来るようにします。

目次へ戻る

「返品書誌情報.xlsm」のモジュールから実行するVBA

tensorenp006

ここからのVBAコード記述なために、「返品書誌情報.xlsm」に新たに標準モジュール（Module3）を追加挿入します。

（挿入の方法はこちら↓で確認できます。）
「ＶＢＥ（ビジュアルベーシックエディター）を起動する」

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

「返品了解申請.xlsm」をVBAで開きます

「返品了解申請.xlsm」は「返品書誌情報.xlsm」と同じディレクトリにあることが必要です。

すでに「返品了解申請.xlsm」が開かれているときはこのプロシージャーはスルーされます。

関連記事

vbadoloopeyecatch VBA 回数不定のループ処理はDo LoopとFor Each vbachdireyecatch ChDirステートメントでカレントフォルダを簡単に変更する

プロシージャー名を「返品申請OPEN」とします。

VBA
Sub 返品申請OPEN()
 Dim flag As Boolean
 Dim Wb As Workbook
 Dim EXN As String
    ChDir ThisWorkbook.Path
    EXN = ThisWorkbook.Path & "\返品了解申請.xlsm"
    flag = False
    For Each Wb In Workbooks
        If Wb.FullName = EXN Then
            flag = True
            Exit For
        End If
    Next Wb
    If flag = False Then
        Workbooks.Open EXN, UpdateLinks:=0
    End If
End Sub

「返品了解申請.xlsm」の「返品本分類」シートにデータを転送

各出版社ごとに作成したシートの返品データを順番に拾っていき、

「返品了解申請.xlsm」の「返品本分類」シートに一覧表形式で表示します。

エラー処理として、対策のためのコードを埋め込みます。

「抽出データ」が空の時（返品書誌データが抽出されていないとき）はプロシージャーを終了します。

「出版社リスト」にある出版社名と出版社別シートが一致しない場合（削除された場合など）のエラーに対しては、その部分は無視して次の出版社の処理を行います。

関連記事

vbasheetvariableeyecatch ワークシートを変数化する3つの手法 オブジェクト変数など VBAGotoeyecatch001 Gotoステートメントでコードをジャンプ！毒と薬の2面性 vbalastcelleyecatch データ入力済セルの最終行番号を取得する fornextirekoeyecatch For～Nextのループと入れ子構造をVBA最速理解 vbacellspaintbackeyecatch 「塗りつぶし」背景色をVBAで記述する vbacolumnseyecatch Columnsプロパティでセルの列を指定する

プロシージャー名を「申請データ転送」とします。

VBA
Sub 申請データ転送()
    Dim HRB As Worksheet
    Dim SJR As Worksheet
    Dim SRow As Long
    Dim SNRow As Long
    Dim j, i, R As Long
    Dim SN As String
        Worksheets("出版社リスト").Select
        R = Cells(Rows.Count, 1).End(xlUp).Row
        If R <= 1 Then
           MsgBox "出版社リストが作成されていません！"
           Worksheets("操作ボタン").Select
           Range("A1").Select
           Exit Sub
        End If
        Set HRB = Workbooks("返品了解申請.xlsm").Worksheets("返品本分類")
        Set SJR = Workbooks("返品書誌情報.xlsm").Worksheets("出版社リスト")
        SJR.Activate
        SRow = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To SRow
            SN = Range("A" & i)
            Workbooks("返品書誌情報.xlsm").Worksheets(SN).Select
            On Error GoTo step1
            SNRow = Cells(Rows.Count, 1).End(xlUp).Row
            HRB.Activate
            R = Cells(Rows.Count, 1).End(xlUp).Row
            If R = 1 Then R = 0
            Range("A" & R + 1).Value = "Ｐ" & i
            Range("B" & R + 1).Value = "ＩＳＢＮ"
            Range("C" & R + 1).Value = "書名"
            Range("D" & R + 1).Value = "出版社名"
            Range("E" & R + 1).Value = "著者名"
            Range("F" & R + 1).Value = "本体価格"
            Range("G" & R + 1).Value = "返品冊数"
            Range("H" & R + 1).Value = "客注名"
            Range("A" & R + 1, "H" & R + 1).Interior.ColorIndex = 35
            For j = 1 To SNRow
                Range("A" & R + 1 + j).Value = Range("A" & R + 1)
            Next j
            Workbooks("返品書誌情報.xlsm").Worksheets(SN).Activate
            Range("A1:G" & SNRow).Copy Destination:=HRB.Range("B" & R + 2)
            SJR.Select
step1:
        Next i
        HRB.Columns.AutoFit
End Sub

２つのプロシージャーを連続実行

今まで作成した２つのプロシージャー「返品申請OPEN」と「申請データ転送」を

連続で実行するプロシージャーを作成します。

プロシージャー名を「連携実行」とします。

vbacalleyecatch 部品化プロシージャーでCallステートメントは必須
VBA
Sub 連携実行()
        Call Module3.返品申請OPEN
        Call Module3.申請データ転送
        Worksheets("操作ボタン").Select
        Range("A1").Select
End Sub

「操作ボタン」シートにボタンを設置

この作業の最後に、

プロシージャー「連携実行」を作動させる「データ転送連携実行」ボタンを「操作ボタン」シートに設置します。

vbabuttoneyecatch コマンドボタンをシートに設置する２つの方法

いつもの設置方法ですが、設置方法の確認はこちら↓でも確認できます。

データ抽出ボタンを設置する。

tensoren001a
目次へ戻る

今回作成したVBAコード

tensorenp007

今回作成したVBAコードはこのような感じになります。

VBA
Option Explicit

Sub 返品申請OPEN()
    Dim flag As Boolean
    Dim Wb As Workbook
    Dim EXN As String
       ChDir ThisWorkbook.Path
       EXN = ThisWorkbook.Path & "\返品了解申請.xlsm"
       flag = False
       For Each Wb In Workbooks
           If Wb.FullName = EXN Then
               flag = True
               Exit For
           End If
       Next Wb
       If flag = False Then
           Workbooks.Open EXN, UpdateLinks:=0
       End If
End Sub

Sub 申請データ転送()
    Dim HRB As Worksheet
    Dim SJR As Worksheet
    Dim SRow As Long
    Dim SNRow As Long
    Dim j, i, R As Long
    Dim SN As String
        Worksheets("出版社リスト").Select
        R = Cells(Rows.Count, 1).End(xlUp).Row
        If R <= 1 Then
           MsgBox "出版社リストが作成されていません！"
           Worksheets("操作ボタン").Select
           Range("A1").Select
           Exit Sub
        End If
        Set HRB = Workbooks("返品了解申請.xlsm").Worksheets("返品本分類")
        Set SJR = Workbooks("返品書誌情報.xlsm").Worksheets("出版社リスト")
        SJR.Activate
        SRow = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To SRow
            SN = Range("A" & i)
            Workbooks("返品書誌情報.xlsm").Worksheets(SN).Select
            On Error GoTo step1
            SNRow = Cells(Rows.Count, 1).End(xlUp).Row
            HRB.Activate
            R = Cells(Rows.Count, 1).End(xlUp).Row
            If R = 1 Then R = 0
            Range("A" & R + 1).Value = "Ｐ" & i
            Range("B" & R + 1).Value = "ＩＳＢＮ"
            Range("C" & R + 1).Value = "書名"
            Range("D" & R + 1).Value = "出版社名"
            Range("E" & R + 1).Value = "著者名"
            Range("F" & R + 1).Value = "本体価格"
            Range("G" & R + 1).Value = "返品冊数"
            Range("H" & R + 1).Value = "客注名"
            Range("A" & R + 1, "H" & R + 1).Interior.ColorIndex = 35
            For j = 1 To SNRow
                Range("A" & R + 1 + j).Value = Range("A" & R + 1)
            Next j
            Workbooks("返品書誌情報.xlsm").Worksheets(SN).Activate
            Range("A1:G" & SNRow).Copy Destination:=HRB.Range("B" & R + 2)
            SJR.Select
step1:
        Next i
        HRB.Columns.AutoFit
End Sub

Sub 連携実行()
        Call Module3.返品申請OPEN
        Call Module3.申請データ転送
        Worksheets("操作ボタン").Select
        Range("A1").Select
End Sub
目次へ戻る

別ブックへのデータ転送のVBA作成のまとめ

tensorenp008

「返品了解申請.xlsm」の「返品本分類」シートの表示は、このようになります。

tensoren004

ここまでの作業で、Webから入手した情報を加工し、

返品了解書テンプレートがある「返品了解申請.xlsm」にデータを送るところまで行いました。

出版社毎に、事前に返品データをチェックや修正したいときは、

出版社リストから作成される各出版社別のシートでおこなうことも出来ます。

次回は、使ったデータをクリアーして、次の使用のためにエクセルBOOK「返品書誌情報.xlsm」をリセットするVBAを組み立てます。

あと、出来上がったＶＢＡの使い方について解説していく予定です。

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

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

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

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

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

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

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

目次へ戻る

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

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

NTTコム サーチ

af_banner01

Dstyle web

dstyleweb_logo
dstyle_320x50-min

前の記事

syosikakoueyecatcha
返品書誌データを出版社別に振り分けた出版社シートの作成

次の記事

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