鴻池です。

"Yoshiaki Kawajiri" <kawa_y@d1.dion.ne.jp> wrote in message
news:3F23B693.8285313@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
                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
        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
******************************