転記マクロ

質問

売り上げ金額の合計を集計するためにマクロを作りたく過去の質問や様々なサイトを見ながらマクロを作成しています。
しかし、どうしても分からない部分があるので詳しい方、お力を貸してください。

★やりたい事
同一フォルダ内に、各チームの売り上げがエクセルに入力してあります。
売り上げの入力されたエクセルのテンプレートは同一で、"売上"タブに
A欄：商品コード、B欄：商品名称、C欄：個数、、、、とAX欄まで続く
となっています。ただし、下へ何行に渡り入力されているかは不明です。
このフォルダ内のデータを1つのエクセルファイルに集約するためのマクロを作成します。

★教えて頂きたいこと
１．以下にある私のTestマクロの"転記"の部分を、Rangeを使っての値貼り付けするための方法
２．各チームが作成したエクセルファイルにある"売上"タブのみを対象とする方法(余分なタブを挿入してしまっているチームがある)
３．Rangeで貼り付けた下に改ページを挿入する方法

よろしくお願い致します。

======================================
Sub Test()

Dim fn, wb, x, i, n, sh, myPath
myPath = ThisWorkbook.Path & "\"
fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイルを検索
Do Until fn = "" '全て検索し終えると、fn = Empty となるので、その間以下を実行

If fn <> ThisWorkbook.Name Then 'ファイルが自分以外なら
Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開く

For Each sh In wb.Worksheets '各シートごとに
x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得
For i = 2 To x '2行目から最終行まで以下を実行
n = n + 1

With ThisWorkbook.Sheets("Sheet1") '転記
.Cells(n, 1) = sh.Cells(i, "A")
.Cells(n, 2) = sh.Cells(i, "B")
.Cells(n, 3) = sh.Cells(i, "C")
.......AX欄まで続く

End With
Next i
Next sh

wb.Close (False) '選択したファイルを閉じる
End If

fn = Dir() '次のファイルを検索
Set wb = Nothing
Loop '繰り返し

ThisWorkbook.Sheets("Sheet1").Copy
Application.Dialogs(xlDialogSaveAs).Show Arg1:="統合.csv", Arg2:=6

End Sub

回答No.4

keithin · ベストアンサー

実際の所は，趣味に応じて色々なアプローチがあります。

sub macro1()
　dim myPath as string
　dim myFile as string
　dim wb as workbook
　dim r as long
　dim s0 = worksheet

　mypath = thisworkbook.path & "\"
　myfile = dir(mypath & "*.xls")
　set s0 = thisworkbook.worksheets("Sheet1")

　do until myfile = ""
　if myfile <> thisworkbook.name then
　　set wb = workbooks.open(mypath & myfile)
　’と，ここまではご質問で掲示されたのとだいたい一緒。

　’回答は実質ここから。
　’万一「売上」シートを抹消していた場合の逃げを用意
　　on error resume next
　’以下はわざわざシートを巡回せず，あるはずの「売上」シートを指しで操作する
　　r = wb.worksheets("売上").range("A65536").end(xlup).row
　　s0.range("A65536").end(xlup).offset(1).resize(r - 1, 50).value _
　　　=wb.workhseets("売上").range("A2:AX" & r).value
　　s0.hpagebreaks.add before:=s0.range("A65536").end(xlup).offset(1)

　’一括転記以降は，またご質問のマクロと一緒
　　wb.close savechanges:=false
　end if
　myfile = dir()
　loop

　thisworkbook.worksheets("Sheet1").copy
　Application.Dialogs(xlDialogSaveAs).Show Arg1:="統合.csv", Arg2:=6
end sub

＃改ページの挿入ぐらいは，回答には書いておきましたけど新しいマクロの記録でご自分で調べられますね？

お礼

ご回答ありがとうとざいました。
なるほど、最終行から入力のあるセルを検索するのですね。
Resizeの使い方も勉強になりました。
ありがとうございました！！

回答No.3

imogasi

質問の表現を吟味すると、下記のようになる。表現の仕方など勉強のこと。
下記ではっきりさせるべきところは、「お礼」欄で補足・注記のこと。
VBAをやるには、コードの作り方だけの学習ではすまない。
エクセルは
ブックの特定
シートの特定
セル・セル範囲（行と列）の特定
対象が単数か複数か
例外があるか
VBAの場合は大筋の処理ロジック（本件ならフォルダの各ブックをよみ、その各シートに当たって、集約シートにコピペ、のようなこと）
判別はどうするのか（名前が多いが）
などの学習なのだ。いつもそれを念頭に質問を記述すること。
ーーー
（１）あるフォルダのエクセルブックを対象にする
注記が必要＝＝＞処理対象外のブック（やエクセル以外のファイル）が混じっているか？
集約シートとそのブックもこのフォルダに入れるのか。前もって作っておくのか。
（２）（１）のブックを開くと、各チームの売上データが別シートがある。
ひゅの様式（列構成）は全シート同じ
ただしシート名が「売上」以外のシートもあるがそれらは処理対象外にする＜ーこの注記はある
表現注意
＞、"売上"タブは、シート名が「売上」のもの、と表現すること。シートタブはあるがそこに見えるのはシート名ですから。
ーー
＞集約するためのマクロを作成します。
シートが別になっているのは、チームか担当者が別だからでは。それを注記するべきだ。
なぜなら集約したシートにチーム名や担当者名は現れるのはどこか。シートタブ（シート名だけか）
集約シートにもチーム名や担当者名は残す必要があるだろう。
＞売上"タブのみを対象
シート名は各ブックに１つか？「４月売上」「５月売上」・・などと入っているのではないか。
明確二説明されていない。
ーー
方針はエクセルの「統合」で行くのか、コピー貼り付けで行くのかなどあるが、本件はコピー貼り付けを考えているらしい
以上の内容を読者にピシッと伝えないと正確なコードは作れない。

お礼

ご指摘ありがとうございます。
指摘箇所は、質問時に説明に苦労した部分でした。
なるほど、、です。

自分の質問に追記させていただきます。

補足

（１）あるフォルダのエクセルブックを対象にする
・集約/処理対象としたいのは集約したいシート"売上"を含むエクセルブック（エクセル以外のファイルは存在しない）。
・1チームが1つのエクセルブックを作成している。
・エクセルブックには必ず１つだけ"売上"シートが存在する
・集約したいシートを含むエクセルブック、および集約シートもあらかじめフォルダに格納されている。

（２）（１）のブックを開くと、各チームの売上データが別シートがある。
・集約したいシートの様式（列構成）は全シート同じ。
・ただしシート名が「売上」以外のシートもあるがそれらは処理対象外にする。

以上の内容で、各チームが作成した"売上"シートの内容を、集約用ブックに値貼り付けで集約したいと考えております。

よろしくお願い致します。

回答No.2

kybo

3の
ActiveSheet.HPageBreaks.Add Before:=.Range("A" & n + 1)　’★追加

を以下に訂正。

.HPageBreaks.Add Before:=.Range("A" & n + 1)

回答No.1

kybo

１．以下にある私のTestマクロの"転記"の部分を、Rangeを使っての値貼り付けするための方法

.Range("A" & n) = sh.Range("A" & i)

とします。

２．各チームが作成したエクセルファイルにある"売上"タブのみを対象とする方法(余分なタブを挿入してしまっているチームがある)

"売上"タブというのが、"売上"という名前のシート名の意味で、そのシートだけのデータを処理したいのであれば、

For Each sh In wb.Worksheets '各シートごとに
If sh.Name = "売上" Then　’★追加

’**現在のコード**

End If　’★追加
Next sh

３．Rangeで貼り付けた下に改ページを挿入する方法

以下を追加

With ThisWorkbook.Sheets("Sheet1") '転記
.Range("A" & n) = sh.Range("A" & i)

'.......AX欄まで続く

ActiveSheet.HPageBreaks.Add Before:=.Range("A" & n + 1)　’★追加
End With

お礼

ありがとうございます！
感謝です！

大変恐縮ですが、もう少し教えてください。

以下、"１．以下にある私のTestマクロの"転記"の部分を、Rangeを使って"についてもう少し教えてください。範囲をマトメて貼り付ける方法がありませんでしょうか。以下（動かなかったのですが）私のイメージです。よろしくお願い致します。
.Range(Cells("A" & n + 15), Cells("CQ" & n + 15 + x)) = sh.Range(sh.Cells("A" & i), Cells("CQ" & x))

もう一つ、各チームが作ったファイルを開くときにパスワードを聞かれた場合に、パスワードを答えるマクロを教えてください。パスワードは一律で"password"です。

よろしくお願い致します。