複数のファイルを1つのシー トに貼り付ける
Sapporo
前に投稿しましたが、消えてしまったので
再度投稿します。
複数のファイルに格納されている特定の１つのシートを
１ファイルの1シートに貼り付けるマクロをご存知の方はいらっしゃいませんか？
ご存知の方がいらっしゃいましたら教えてください。
abc.xlsの1シートに
123456789
4848459456123
15875abcder
efg.xlsの1シート
15987594569
158789657
15798711
58978564
とあるものを
merck.xlsに
123456789
4848459456123
15875abcder
15987594569
158789657
15798711
58978564
とする方法です。
マクロをどう書いたらいいでしょうか？
複数のファイルを開くのは出来ましたが、１シートにデータを貼り付けるのが難しい
です。
御教授ください。
------------------------------------
Yoshiaki Kawajiri
Yoshiaki...@toll.co.jp
koun...@mbh.nifty.com
"Sapporo" <etc.s...@luck.ocn.ne.jp> wrote in message
news:b4sf19$mbq$1...@nn-tk103.ocn.ad.jp...
> 川尻＠札幌です。
> 複数のファイルに格納されている特定の１つのシートを
> １ファイルの1シートに貼り付けるマクロをご存知の方はいらっしゃいませんか？
> ご存知の方がいらっしゃいましたら教えてください。
> abc.xlsの1シートに
> 123456789
> 複数のファイルを開くのは出来ましたが、
特定のシートがすべて同じ名前でよいなら，複数のファイルを開いた状態で，以下の
マクロを実行。このマクロをコピーしたいブックのモジュールに書くこと。連続した
データでなくても，途中に空白行があっても動作するようにしてますが。（少々長っ
たらしく，ちょっと不細工な所もありますが。）
詳細には，確認していないので正常に動くかは不明。
----------------------以下-----------------------------------------
Sub start_copysheet()
#Const beta = 1 '確認が不要の場合は値を０にする。
Dim tobook As Workbook
Dim tosheet As Worksheet
Dim frombook As String
Dim fromsheet As String
Dim lrto As Long
Dim lrfrom As Long
Const sh = "sheet1" '特定のシート名はここで変更する。
Set tobook = ActiveWorkbook
Set tosheet = ActiveSheet
For Each bk In Workbooks
tobook.Activate
tosheet.Select
lrto = find_last_row()
bk.Activate
If tobook.Name <> bk.Name Then
On Error GoTo errnotfind
Sheets(sh).Select
lrfrom = find_last_row()
Rows(Trim(Str(1)) & ":" & Trim(Str(lrfrom))).Select
Selection.Copy
tobook.Activate
tosheet.Activate
On Error GoTo errov
#If beta Then
Cells(lrto + 2, 1).Select
Selection.PasteSpecial
Application.CutCopyMode = False
Cells(lrto + 1, 1).Value = bk.Name & " + (シート名: " & sh &
")"
Cells(lrto + 1, 1).Font.ColorIndex = 3
#Else
Cells(lrto + 1, 1).Select
Selection.PasteSpecial
#End If
End If
ne:
Next
Exit Sub
errnotfind:
MsgBox bk.Name & " のシート " & sh & " が見つかりません。"
Resume ne
errov:
MsgBox "コピー行数が多すぎます。"
End Sub
Function find_last_row() As Long
Dim sm As Range
Dim pre As Range
Dim n, m As Integer
On Error GoTo errfs
Set pre = ActiveCell
Cells.SpecialCells(xlCellTypeConstants, 23).Select
Set sm = Selection
n = sm.Areas.Count
sm.Areas(n).Select
Set sm = Selection
If sm.Count > 1 Then
sm.End(xlDown).Select
n = Selection.Row
Else
n = Selection.Row
End If
fs:
On Error GoTo errse
Cells.SpecialCells(xlCellTypeFormulas, 23).Select
Set sm = Selection
m = sm.Areas.Count
sm.Areas(m).Select
Set sm = Selection
If sm.Count > 1 Then
sm.End(xlDown).Select
m = Selection.Row
Else
m = Selection.Row
End If
se:
pre.Activate
If n > m Then
find_last_row = n
Else
find_last_row = m
End If
Exit Function
errfs:
n = 0
Resume fs
errse:
m = 0
Resume se
End Function
---------------------------以上------------------------------------
--
******************************
keizi kounoike
******************************
Koichiro
>再度投稿します。
>複数のファイルに格納されている特定の１つのシートを
>１ファイルの1シートに貼り付けるマクロをご存知の方はいらっしゃいませんか？
>ご存知の方がいらっしゃいましたら教えてください。
Yoshiaki Kawajiri
先般に続きの質問です。
61_20030701_NAME集計2.xls
61_20030702_NAME集計2.xls
61_20030703_NAME集計2.xls
61_20030704_NAME集計2.xls
のそれぞれのファイルにあるSheet(1)シートの内容を
交通量 7月分NAME集計2.xls
の合計というシートに
61_20030701_NAME集計2.xls
61_20030702_NAME集計2.xls
61_20030703_NAME集計2.xls
61_20030704_NAME集計2.xls
のそれぞれのファイルにあるSheet(1)シートの内容を
張り付けたいと考えています。
例えばファイル
61_20030704_NAME集計2.xlsは
7が月で、4が日です。
月は毎月違います。データのファイルは1ヶ月分ですが
20日までのデータまでだったりします。
自分の欲望として、マクロ(VBA)を起動すると *_NAME集計2.xls
だけを参照し自動的に 合計シートの張り付けられるのが自分でやってみたのですが
なかなか難しいです。以前 kounoikeさんから教えていただいた物を使ってみましたが
自分の考えている物とどういうふうに組むかが解りません。
お知恵を貸していただけたらと思います。
どうぞよろしくお願いいたします。
-------
Yoshiaki Kawajiri
koun...@mbh.nifty.com
"Yoshiaki Kawajiri" <kaw...@d1.dion.ne.jp> wrote in message
news:3F23B693...@d1.dion.ne.jp...
> 川尻＠札幌です。
> 自分の欲望として、マクロ(VBA)を起動すると *_NAME集計2.xls
> だけを参照し自動的に 合計シートの張り付けられるのが自分でやってみたのです
が
> なかなか難しいです。以前 kounoikeさんから教えていただいた物を使ってみまし
たが
> 自分の考えている物とどういうふうに組むかが解りません。
以前のは，データが無いシートがある場合の動きが間違っていたので，修正したのを
下記に書きました。（まだ，間違いがあるかも知れません。また，エラー処理は不十
分。）
川尻さんが，コピーしたいファイルを開くマクロは作成しているというので，それを
前提に以前のマクロは作成しました。また，コピーするシート名（下記では，
"sheet1"）も全て同じという条件です。組み合わせる場合は，若干マクロを変更した
方が，使用勝手がよいような気がします。変更したものを下記に書きます。
組み合わせとしては，川尻さんが作成したマクロ名を仮に，open_allfileとすれば，
これをマクロだけ記述するファイル（ファイル名は適当に付ける。）のモジュールに
コピーします。また，以下のコードも同じモジュールにコピーします。
そして，そのモジュールに例えば次のようなマクロ，
sub start_test()
Dim tobook As Workbook
Dim tosheet As Worksheet
Set tobook = ActiveWorkbook
Set tosheet = ActiveSheet
open_allfile
start_copysheet tobook, tosheet
end sub
を作成します。
そして，集計するファイルの合計のシートをアクティブにした状態で，上の
start_testを実行する。といった感じで試して見てはどうでしょうか。
この場合，最大で３３（データ，集計用，マクロ用）のファイルが一度に開かれるこ
とになり，それが嫌なら，一個ずつ目的のファイルを開いてコピーし，終わればファ
イルを閉じるようにすればいいと思います。データファイルを同一ディレクトリに保
存するようにすれば，そう複雑にはならないと思います。例えば，
-----------------一個づつ開いてコピーの場合-----------------
Sub file_copy()
Dim tobook As Workbook
Dim tosheet As Worksheet
Dim foldername As String
Set tobook = ActiveWorkbook
Set tosheet = ActiveSheet
'ここにinput文でフォルダを選択する方法をとるべき？。
foldername = "C:\My Documents\data" 'データの保存場所
open_and_copy foldername, tobook, tosheet
End Sub
Sub open_and_copy(folderspec As String, tobook As Workbook, tosheet As
Worksheet)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
Workbooks.Open f1.Name
start_copysheet tobook, tosheet
Workbooks(f1.Name).Close SaveChanges:=False
Next
End Sub
-------------------以上------------------------------------
を作成。そして集計するファイルの合計のシートをアクティブにした状態で，上の
file_copyを実行する。なお，start_copysheet は下記を利用。
--------------------組み合わせ用マクロ----------------------
Sub start_copysheet(tobook As Workbook, tosheet As Worksheet)
#Const beta = 1 '確認が不要の場合は値を０にする。
Dim lrto As Long
Dim lrfrom As Long
Const sh = "sheet1" '特定のシート名はここで変更する。Sheet(1)ではない。
For Each bk In Workbooks
tobook.Activate
tosheet.Select
lrto = find_last_row()
bk.Activate
If Not ThisWorkbook Is bk And Not tobook Is bk Then
On Error GoTo errnotfind
Sheets(sh).Select
lrfrom = find_last_row()
If lrfrom > 0 Then