質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

91.35%

  • VBA

    1125questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    968questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

【EXCEL VBA】複数のブックに分かれた転記元エクセルの内容を、転記先のデータベースブックに転記したい

解決済

回答 1

投稿 2017/12/01 14:18

  • 評価
  • クリップ 0
  • VIEW 107

vbabeginner

score 5

前提・実現したいこと

見積書のデータが複数のブックにわかれて保存されており、別のブックに手入力でコピペしながら、
見積書内の「見積書番号・件名・納入期日・品名・数量・単位・単 価・金 額」
」の内容が一覧化されたデータベース台帳を作っています。
まだまだ見積書があって、ひとつひとつコピペして手入力は大変なので、自動転記されるマクロをつくりたいと考えています。
P.S.マクロは初めてです。ネットや本で調べましたが、解決できず、周りにも聞ける方がいないので、こちらにたどり着きました。質問の仕方など至らないことあるかもしれませんが、もし不足している情報などがあればご指摘いただき、お手柔らかにご対応いただけると幸いです。

発生している問題・エラーメッセージ

「マクロの記録」アイコンから、マクロを記録すると、実行する際に、ファイル名のエラーが出ます。
(転記完了した転記元ファイルは、「転記済」フォルダに移動させているため)
そこで、workbook.nameというコードに置き換えましたが、今度は、転記元にペーストされてしまったり、転記先セルへのペーストがずれてしまいます。

該当のソースコード

Sub 見積書DB化()
'
' 見積書DB化 Macro
'

'「現在開いているブック」を定義
MsgBox ActiveWorkbook.Name
'「VBAコードを記述したブック」を定義

'入力する空白セルの指定
InputRow = Cells(Rows.Count, "a").End(xlUp).Row + 1
'見積もり番号を開いている転記元からコピーして転記先にペースト
MsgBox ActiveWorkbook.Name
Range("K2").Select
Selection.Copy
Windows("転記先_2016nov-2017oct_見積書DB.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'件名'を開いている転記元からコピーして転記先にペースト
MsgBox ActiveWorkbook.Name
Range("D8").Select
Application.CutCopyMode = False
Selection.Copy
Windows("転記先_2016nov-2017oct_見積書DB.xlsm").Activate
InputRow = Cells(Rows.Count, "b").End(xlUp).Row + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
MsgBox ActiveWorkbook.Name
'納入期日'を開いている転記元からコピーして転記先にペースト
Range("D9").Select
Application.CutCopyMode = False
Selection.Copy
Windows("転記先_2016nov-2017oct_見積書DB.xlsm").Activate
InputRow = Cells(Rows.Count, "c").End(xlUp).Row + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'品名'を開いている転記元からコピーして転記先にペースト
MsgBox ActiveWorkbook.Name
Range("C18").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("転記先_2016nov-2017oct_見積書DB.xlsm").Activate
InputRow = Cells(Rows.Count, "d").End(xlUp).Row + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'数量~金額'を開いている転記元からコピーして転記先にペースト
MsgBox ActiveWorkbook.Name
Range("F18:I18").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("転記先_2016nov-2017oct_見積書DB.xlsm").Activate
InputRow = Cells(Rows.Count, "e").End(xlUp).Row + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

試したこと

課題に対してアプローチしたことを記載してください

補足情報(言語/FW/ツール等のバージョンなど)

excel2016 を使っています。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • kikukiku

    2017/12/01 14:52

    ExcelVBAの学習であれば私もお世話になりました(http://excel-ubara.com/excelvba1/)が参考になります。第1回から第43回までの読み飛ばさずに学習していけば、やりたいことは実現できると思います。

    キャンセル

  • vbabeginner

    2017/12/01 15:00

    早速のご返信ありがとうございます。リンクみてみます。

    キャンセル

回答 1

checkベストアンサー

0

いきなりこれを出すのは微妙な気がしますが
求める場所までちょっと遠そうな気がしましたので

いくつかポイント

  • Excel.ThisWorkbookを参照すると、マクロが書かれているブックを取得できる
  • 複数のシート・ブックにまたがる処理は、対象のシートを変数に入れておき、その変数経由で操作する
  • Active~Selection、親の無い(.の無い)RangeCellはExcelの状況によって指すものがコロコロ変わるので、変数に入れた方が堅牢になる
Option Explicit

Sub 見積書DB化2()
    '前提条件
    '- 転記元のシートを前面に表示していること
    '- 転記先のシートがこのマクロが書かれいるブックであること

    If Excel.ThisWorkbook Is Excel.ActiveWorkbook Then
        Stop '転記先と転記元が同じブック
        Exit Sub
    End If

    '転記元のシートを取得
        'Excelで今アクティブなシート(Excel.ActiveWorkbookは省略可)
    Dim copyWs As Excel.Worksheet
    Set copyWs = Excel.ActiveWorkbook.ActiveSheet

    '転記先のシートを取得
        'マクロが書かれているブックの、アクティブなシート
    Dim pasteWs As Excel.Worksheet
    Set pasteWs = Excel.ThisWorkbook.ActiveSheet

    '入力する空白セルの指定
    Dim pasteCell As Excel.Range '元の処理の`InputRow`に相当する場所のセル
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "A").End(xlUp).Offset(1)

    '見積もり番号を開いている転記元からコピーして転記先にペースト
    Dim mitumoriCell As Excel.Range
    Set mitumoriCell = copyWs.Range("K2")

    mitumoriCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'pasteCell.Value() = mitumoriCell.Value()


    '件名'を開いている転記元からコピーして転記先にペースト
        '見積もり番号とやっていることはほぼ同じ
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "B").End(xlUp).Offset(1)

    Dim kenmeiCell As Excel.Range
    Set kenmeiCell = copyWs.Range("D8")

    kenmeiCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'pasteCell.Value() = kenmeiCell.Value()


    '納入期日'を開いている転記元からコピーして転記先にペースト
        '見積もり番号とやっていることはほぼ同じ
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "C").End(xlUp).Offset(1)

    Dim nonyuCell As Excel.Range
    Set nonyuCell = copyWs.Range("D9")

    nonyuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'pasteCell.Value() = nonyuCell.Value()


    '品名'を開いている転記元からコピーして転記先にペースト
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(1)

    Dim hinmeiCell As Excel.Range
    With copyWs
        Set hinmeiCell = _
                .Range( _
                    .Range("C18"), _
                    .Range("C18").End(xlDown) _
                )
        '以下処理で選択したセルと同じものを取得しているはずです
        'Range("C18").Select
        'Range(Selection, Selection.End(xlDown)).Select

    End With 'copyWs


    hinmeiCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'pasteCell.Resize(hinmeiCell.Rows.Count).Value() = hinmeiCell.Value()


    '数量~金額'を開いている転記元からコピーして転記先にペースト
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "E").End(xlUp).Offset(1)

    Dim suryo_kingakuCell As Excel.Range
    With copyWs
        Set suryo_kingakuCell = _
                .Range( _
                    .Range("F18:I18"), _
                    .Range("F18:I18").End(xlToRight).End(xlDown) _
                )
        '以下処理で選択したセルと同じものを取得しているはずです
            '元々入っていたので`.End(xlToRight)`を入れていますが要るのでしょうか?
        'Range("F18:I18").Select
        'Range(Selection, Selection.End(xlToRight)).Select
        'Range(Selection, Selection.End(xlDown)).Select

    End With 'copyWs

    suryo_kingakuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'With suryo_kingakuCell
        'pasteCell.Resize(.Rows.Count, .Columns.Count).Value() = .Value()
    'End With 'suryo_kingakuCell

End Sub

投稿 2017/12/01 23:46

編集 2017/12/02 01:22

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/12/06 13:13

    早速の添削いただきありがとうございます。
    確認とお礼が遅くなり大変恐縮です。
    わかりやすく、ポイントお教えいただき大変理解しやすく助かりました。
    まだ、転記先のセルにきちんとコピーペーストできず、もう少し検証してみてみます。

    最初は、転記先のこちらのマクロが組み込まれたブックを開き、そのブックのファイルから転記元の見積書データを開いてブックの最前列のシートになるよう移動してから、マクロの実行を転記元からボタンおせばよろしいのですよね?

    キャンセル

  • 2017/12/06 20:54

    転記元のブックを最前面にしてから、このマクロを実行するという手順で大丈夫です。
    ただ、元の処理の行間を埋める形で作成したので、意図をくみ取り切れていない部分があるのだと思います。

    私の書いた処理ではセルの選択をしていないので、少し書き換えて
    ブレークポイントで処理を一時停止しつつ、対象の範囲を確認しながら実行すると意図しない動作の部分がわかりやすいかと思います。

    セルの選択ですが、例えば`pasteCell`がどこを指しているか確認したい場合
    `pasteWs.Activate: pasteCell.Activate`や
    `Call Excel.Application.Goto(pasteCell)`
    を実行すると、そのセル範囲を選択できます。

    キャンセル

  • 2017/12/08 14:28

    わかりやすいご解説ありがとうございます!
    「 If Excel.ThisWorkbook Is Excel.ActiveWorkbook Then
    Stop '転記先と転記元が同じブック
    Exit Sub
    End If
    」を
    削除し、転記元の見積書データをひとつのフォルダに整理してみましたら、おかげさまで無事転記が一撃でできるようになりました!
    大変にありがとうございます!!

    自分でまたさらにひと手間でも減らせるように、もう少し試行錯誤してみます。
    具体的にコードをお教えいただいたことで、
    VBAの仕組み?みたいな、今まで本やネットで自力で調べてもイメージできなかったことがぐっとなんとなくでもわかりました!!ありがとうございます。


    またわからないことが出てくると思いますが、
    またお問い合わせさせていただければ幸いです。

    取り急ぎのお礼までで恐縮ですが、どうぞよろしくお願いいたします!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

ただいまの回答率

91.35%

関連した質問

同じタグがついた質問を見る

  • VBA

    1125questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    968questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • トップ
  • VBAに関する質問
  • 【EXCEL VBA】複数のブックに分かれた転記元エクセルの内容を、転記先のデータベースブックに転記したい