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

###前提・実現したいこと
見積書のデータが複数のブックにわかれて保存されており、別のブックに手入力でコピペしながら、
見積書内の「見積書番号・件名・納入期日・品名・数量・単位・単　価・金　額」
」の内容が一覧化されたデータベース台帳を作っています。
まだまだ見積書があって、ひとつひとつコピペして手入力は大変なので、自動転記されるマクロをつくりたいと考えています。
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 を使っています。

kikukiku

2017/12/01 05:52

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

退会済みユーザー

2017/12/01 06:00

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

行動規範の内容に同意します

回答1件

ベストアンサー

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

いくつかポイント

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

vba
1Option Explicit
2
3Sub 見積書DB化2()
4    '前提条件
5    '- 転記元のシートを前面に表示していること
6    '- 転記先のシートがこのマクロが書かれいるブックであること
7    
8    If Excel.ThisWorkbook Is Excel.ActiveWorkbook Then
9        Stop '転記先と転記元が同じブック
10        Exit Sub
11    End If
12    
13    '転記元のシートを取得
14        'Excelで今アクティブなシート（Excel.ActiveWorkbookは省略可）
15    Dim copyWs As Excel.Worksheet
16    Set copyWs = Excel.ActiveWorkbook.ActiveSheet
17    
18    '転記先のシートを取得
19        'マクロが書かれているブックの、アクティブなシート
20    Dim pasteWs As Excel.Worksheet
21    Set pasteWs = Excel.ThisWorkbook.ActiveSheet
22    
23    '入力する空白セルの指定
24    Dim pasteCell As Excel.Range '元の処理の`InputRow`に相当する場所のセル
25    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "A").End(xlUp).Offset(1)
26    
27    '見積もり番号を開いている転記元からコピーして転記先にペースト
28    Dim mitumoriCell As Excel.Range
29    Set mitumoriCell = copyWs.Range("K2")
30    
31    mitumoriCell.Copy
32    pasteCell.PasteSpecial Paste:=xlPasteValues, _
33                           Operation:=xlNone, _
34                           SkipBlanks:=False, _
35                           Transpose:=False
36    'コピペは以下でも可
37    'pasteCell.Value() = mitumoriCell.Value()
38    
39    
40    '件名'を開いている転記元からコピーして転記先にペースト
41        '見積もり番号とやっていることはほぼ同じ
42    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "B").End(xlUp).Offset(1)
43    
44    Dim kenmeiCell As Excel.Range
45    Set kenmeiCell = copyWs.Range("D8")
46    
47    kenmeiCell.Copy
48    pasteCell.PasteSpecial Paste:=xlPasteValues, _
49                           Operation:=xlNone, _
50                           SkipBlanks:=False, _
51                           Transpose:=False
52    'コピペは以下でも可
53    'pasteCell.Value() = kenmeiCell.Value()
54    
55    
56    '納入期日'を開いている転記元からコピーして転記先にペースト
57        '見積もり番号とやっていることはほぼ同じ
58    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "C").End(xlUp).Offset(1)
59    
60    Dim nonyuCell As Excel.Range
61    Set nonyuCell = copyWs.Range("D9")
62    
63    nonyuCell.Copy
64    pasteCell.PasteSpecial Paste:=xlPasteValues, _
65                           Operation:=xlNone, _
66                           SkipBlanks:=False, _
67                           Transpose:=False
68    'コピペは以下でも可
69    'pasteCell.Value() = nonyuCell.Value()
70    
71    
72    '品名'を開いている転記元からコピーして転記先にペースト
73    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(1)
74    
75    Dim hinmeiCell As Excel.Range
76    With copyWs
77        Set hinmeiCell = _
78                .Range( _
79                    .Range("C18"), _
80                    .Range("C18").End(xlDown) _
81                )
82        '以下処理で選択したセルと同じものを取得しているはずです
83        'Range("C18").Select
84        'Range(Selection, Selection.End(xlDown)).Select
85        
86    End With 'copyWs
87    
88    
89    hinmeiCell.Copy
90    pasteCell.PasteSpecial Paste:=xlPasteValues, _
91                           Operation:=xlNone, _
92                           SkipBlanks:=False, _
93                           Transpose:=False
94    'コピペは以下でも可
95    'pasteCell.Resize(hinmeiCell.Rows.Count).Value() = hinmeiCell.Value()
96    
97    
98    '数量～金額'を開いている転記元からコピーして転記先にペースト
99    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "E").End(xlUp).Offset(1)
100    
101    Dim suryo_kingakuCell As Excel.Range
102    With copyWs
103        Set suryo_kingakuCell = _
104                .Range( _
105                    .Range("F18:I18"), _
106                    .Range("F18:I18").End(xlToRight).End(xlDown) _
107                )
108        '以下処理で選択したセルと同じものを取得しているはずです
109            '元々入っていたので`.End(xlToRight)`を入れていますが要るのでしょうか？
110        'Range("F18:I18").Select
111        'Range(Selection, Selection.End(xlToRight)).Select
112        'Range(Selection, Selection.End(xlDown)).Select
113        
114    End With 'copyWs
115    
116    suryo_kingakuCell.Copy
117    pasteCell.PasteSpecial Paste:=xlPasteValues, _
118                           Operation:=xlNone, _
119                           SkipBlanks:=False, _
120                           Transpose:=False
121    'コピペは以下でも可
122    'With suryo_kingakuCell
123        'pasteCell.Resize(.Rows.Count, .Columns.Count).Value() = .Value()
124    'End With 'suryo_kingakuCell
125    
126End Sub

投稿2017/12/01 14:46

編集2017/12/01 16:22

imihito

総合スコア2166

退会済みユーザー

2017/12/06 04:13

早速の添削いただきありがとうございます。確認とお礼が遅くなり大変恐縮です。わかりやすく、ポイントお教えいただき大変理解しやすく助かりました。まだ、転記先のセルにきちんとコピーペーストできず、もう少し検証してみてみます。最初は、転記先のこちらのマクロが組み込まれたブックを開き、そのブックのファイルから転記元の見積書データを開いてブックの最前列のシートになるよう移動してから、マクロの実行を転記元からボタンおせばよろしいのですよね？

imihito

2017/12/06 11:54

転記元のブックを最前面にしてから、このマクロを実行するという手順で大丈夫です。ただ、元の処理の行間を埋める形で作成したので、意図をくみ取り切れていない部分があるのだと思います。私の書いた処理ではセルの選択をしていないので、少し書き換えてブレークポイントで処理を一時停止しつつ、対象の範囲を確認しながら実行すると意図しない動作の部分がわかりやすいかと思います。セルの選択ですが、例えば`pasteCell`がどこを指しているか確認したい場合 `pasteWs.Activate: pasteCell.Activate`や `Call Excel.Application.Goto(pasteCell)` を実行すると、そのセル範囲を選択できます。

退会済みユーザー

2017/12/08 05:28

わかりやすいご解説ありがとうございます！「 If Excel.ThisWorkbook Is Excel.ActiveWorkbook Then Stop '転記先と転記元が同じブック Exit Sub End If 」を削除し、転記元の見積書データをひとつのフォルダに整理してみましたら、おかげさまで無事転記が一撃でできるようになりました！大変にありがとうございます！！自分でまたさらにひと手間でも減らせるように、もう少し試行錯誤してみます。具体的にコードをお教えいただいたことで、 VBAの仕組み？みたいな、今まで本やネットで自力で調べてもイメージできなかったことがぐっとなんとなくでもわかりました！！ありがとうございます。またわからないことが出てくると思いますが、またお問い合わせさせていただければ幸いです。取り急ぎのお礼までで恐縮ですが、どうぞよろしくお願いいたします！

行動規範の内容に同意します