[[20050314145633]]　『数個のブックを1つにまとめたい』（ワケワカラン）　ページの最後に飛ぶ

『数個のブックを1つにまとめたい』（ワケワカラン）

「子1」と「子2」というブックのデーターを「親」と言うブックにまとめたいのです

手作業なら

1.「子1」のブックを開く

2.データーをコピーする

3.親に貼り付け

4.「子2」のブックを開く

5.データーをコピーする

6.親に貼り付ける（子1の下）

これをマクロ等でやりたいのです。

データーの行はそのつど違います。ので、子2の始まりは子1のデーターの下につけたい

です。

よろしくお願いします

今、単語検索で同じようなものを発見しました。

もう少し悩んでみます。

検索の単語が違うとなかなかみつからなかったので、質問をさせていただきました。

すみません

（ワケワカラン）

やはり、難しいです。

Option Explicit

Public Sub DataCollection()

    Dim i As Long 
    Dim vntBookName As Variant 
    Dim wkbData As Workbook 
    Dim wksData As Worksheet 
    Dim wkbResult As Workbook 
    Dim wksResult As Worksheet

    '転記元Bookを取得（複数選択） 
    If Not GetReadFile(vntBookName, ThisWorkbook.Path, True) Then 
        Exit Sub 
    End If

    Application.ScreenUpdating = False

    'データを書き込むBookを設定 
    Set wkbResult = ThisWorkbook

    '選択されたBook全てに就いて繰り返し 
    For i = 1 To UBound(vntBookName) 
        'BookをOpenしする 
        Set wkbData = Workbooks.Open(vntBookName(i)) 
        With wkbData 
            'OpenしたBookのSheet全てに就いて繰り返し 
            For Each wksData In .Worksheets 
                'もし、書き込むシートが無い場合シートを追加 
                If Not GetWriteSheet(wksData.Name, wksResult, wkbResult) Then 
                    Set wksResult = wkbResult.Worksheets.Add 
                    wksResult.Name = wksData.Name 
                End If 
                'データを書き込み 
                DataWrite wksData, wksResult 
            Next wksData 
            'BookをClose 
            .Close SaveChanges:=False 
        End With 
    Next i

    Set wkbData = Nothing 
    Set wksData = Nothing 
    Set wksResult = Nothing 
    Set wkbResult = Nothing

    Application.ScreenUpdating = True

    Beep 
    MsgBox "処理が終了しました"

End Sub

Private Sub DataWrite(wksData As Worksheet, wksWite As Worksheet)

    Dim lngRows As Long 
    Dim lngWite As Long

    '書き込むSheet 
    With wksWite 
        '最終行を取得 
        lngWite = .Cells(65536, "B").End(xlUp).Row 
        If lngWite = 1 And .Cells(1, "B").Value = "" Then 
            lngWite = 1 
        Else 
            lngWite = lngWite + 1 
        End If 
    End With

    'データの有るSheet 
    With wksData 
        '最終行を取得 
        lngRows = .Cells(65536, "B").End(xlUp).Row 
        'データをCopy 
        .Cells(1, "B").Resize(lngRows, 11).Copy _ 
                Destination:=wksWite.Cells(lngWite, "B") 
    End With

End Sub

Private Function GetWriteSheet(strName As String, _

                                wksWrite As Worksheet, _ 
                                wkbWrite As Workbook) As Boolean 
'   Sheetの存在確認

    Dim wksResult As Worksheet 
    Dim blnExist As Boolean

    '書き込むBookに就いて 
    With wkbWrite 
        'WorkSheet全てに就いて繰り返し 
        For Each wksResult In .Worksheets 
            'もし、シート名が有るなら 
            If wksResult.Name = strName Then 
                '戻り値をTrueに 
                blnExist = True 
                '書き込みSheetを返す 
                Set wksWrite = wksResult 
                Exit For 
            End If 
        Next wksResult 
    End With

    GetWriteSheet = blnExist

End Function

Private Function GetReadFile(vntFileNames As Variant, _

                        Optional strFilePath As String, _ 
                        Optional blnMultiSel As Boolean _ 
                                        = False) As Boolean

    Dim strFilter As String

    'フィルタ文字列を作成 
    strFilter = "Excel File (*.xls),*.xls," _ 
                    & "全て (*.*),*.*" 
    '読み込むファイルの有るフォルダを指定 
    If strFilePath <> "" Then 
        'ファイルを開くダイアログ表示ホルダに移動 
        ChDrive Left(strFilePath, 1) 
        ChDir strFilePath 
    End If 
    'もし、ディフォルトのファイル名が有る場合 
    If vntFileNames <> "" Then 
        SendKeys vntFileNames & "{TAB}", False 
    End If 
    '「ファイルを開く」ダイアログを表示 
    vntFileNames _ 
            = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel) 
    If VarType(vntFileNames) = vbBoolean Then 
        Exit Function 
    End If

    GetReadFile = True

End Function

を貼り付けました。

が、これだと、新しくシートをつくって、そこにコピーになります。

このマクロをくんでいるブックの「まとめ」というシートに貼り付けたいのです。

「まとめ」というシートはすでに作ってあります。

どうしたらいいでしょうか？

（ワケワカラン）

 基本形は次のようなマクロでよいと思います。
　　
 Sub TEST_20050314()
    Const MyPath As String = "C:\test\"
    Dim MyBook As Workbook
    Dim MyFileName As String
    Dim MyRng As Range
    MyFileName = Dir(MyPath & "*.xls")

    Do While MyFileName <> ""
        If ThisWorkbook.Name <> MyFileName Then
        Set MyBook = Workbooks.Open(MyPath & MyFileName)

        Set MyRng = ThisWorkbook.Sheets("まとめ").Range("A65536").End(xlUp).Offset(1)
        MyBook.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=MyRng
        MyBook.Close
        End If
        MyFileName = Dir()
    Loop
 End Sub
　
味付けとしては「子1」「子2」のシート名。
（みやほりん）

基本形を貼り付けてみましたが、なにも起こりません。

味付けが下手なのでしょうか.....

"C:\test\"にはコピー元を入れるのでしょうか？

素人ですみません。

最初にコピーするデーターを選択するようにしたいのです。

ちなみにコピーするデーターはCSVデーターです。

（ワケワカラン）

 味付け以前の問題なんですが、
＞ 1.「子1」のブックを開く
とあったのでそのようにしました。
完全なOutputには正確なInputが必要ですね。
    Const MyPath As String = "C:\test\"
　　　・
    MyFileName = Dir(MyPath & "*.xls")
　　　・
    MyBook.Sheets(1)Range("A1").CurrentRegion.Copy ・・・・
とあるように、提示のものは
　
「C:\test」のフォルダにある、
　　全ての「エクセルブック」の
　　　　「一番左側」のシートの、
　　　　　　「A1」セルのアクティブセル範囲を
「親」ブックの
　　「まとめ」シートへコピー貼り付けするものです。
　
したがって、それら「」の項目のどれかが外れると用をなしません。
　
環境に合わせてカスタマイズしてください。
    Const MyPath As String = "C:\test\"　←CSVの保存してあるフォルダ名パス
    MyFileName = Dir(MyPath & "*.xls")　←"*.xls"を"*.csv"に
（みやほりん）
【追記】
もとのデータをこわすことはないと思い、注意喚起をしなかった私も悪いのですが、
マクロは「それらしきもの」を適当に使うと大切なデータを失う結果にもなるので
他人の作ったコードをそのまま使う時はご用心を。

ありがとうございました。

なんとかできました。

（ワケワカラン）

横からすいません。

 ここにあるﾏｸﾛをコピーしてやってみたのですが
 なぜかうまいこといきません。
 ブックは30個程度　ｼｰﾄは*4程度（ﾌﾞｯｸによってﾊﾞﾗﾊﾞﾗ）程度あると思います。
 ﾌﾞｯｸの中には表（LIST)とｸﾞﾗﾌが入っていますが
 LISTしかできないのですが，何か問題あるのでしょうか？
 宜しくお願いします。　（てつ）

 このような掲示板に掲載されているマクロは個々の相談者のために特化したものが
多いので、そのまま他の方が使って良い結果が出るとは思えません。
　
どういう働きをしているマクロなのか、理解できていないものを使用するのは
おやめください。（データが復元できない場合もあるのです）
　
で、二種類のコードのうちどちらを使ったのでしょう。
TEST_20050314ならフォローします。
(みやほりん)(-_∂)b

 最初に掲載されているのはこちらで提案されたもののようです。
http://park7.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200502/05020076.txt
出典：エクセルファンクラブ　Q&A　ラウンジ
http://www.fuji.ne.jp/~excelyou/
　
INAさんの名前が見えますね。
(みやほりん)(-_∂)b

 少し違いました。
 私の場合はただﾎﾙﾀﾞｰに入っている全ファイル中の全ｼｰﾄを
 一つにまとめるだけでよかったのですが･･･
 別に1つのｼｰﾄにまとめるわけではなく･･･

 っでそこでいろいろやっていたのですが，
 どうしてもうまいこといかないのです。
 例えばファイル101.XLSに
 A101－JPN－LIST，A101-JPN-GRAPH，A101-NAS-LIST，A101-EU-GRAPH
 というｼｰﾄがあったとします
 そこでﾏｸﾛを実行するとLISTのｼｰﾄしか抜き出せないのです。

 実行したマクロはフリーのソフトもそうですが，
 http://www.excel.studio-kazu.jp/cgi-bin/kazuwiki2.cgi?mycmd=read&mypage=[[20050210100639]]
 にあるﾏｸﾛでもそうなってしまいます。
 場所違いですがお願いします。

 GRAPHｼｰﾄはLISTの表からｸﾞﾗﾌを作成しているから抜き出せないのでしょうか？
 リンク先で実行したマクロを貼り付けておきます。

 Sub 複数のブックのシートを一つブックにまとめる()
     On Error GoTo ErrorHandler
     Dim strPath As String
     Dim strBookName As String
     Dim TargetBook As Workbook
     Dim OriginalSheet As Worksheet
     '指定した場所にあるxlsファイルについて処理
     strPath = ThisWorkbook.Path '自分自身と同じ場所とする
     strBookName = Dir(strPath & "\*.xls") 'ファイル名取得
     '対象ファイルが存在する限り処理
     Do While strBookName <> ""
         If ThisWorkbook.Name <> strBookName Then '自分自身じゃないなら
             'そのブックを開く
              Set TargetBook = Workbooks.Open(strPath & "\" & strBookName)
             '開いたブックの全てのシートを処理
             For Each OriginalSheet In TargetBook.Worksheets
                 '開いたブックのシートを自身の最後にコピー
                 OriginalSheet.Copy After:=ThisWorkbook.Worksheets  　(ThisWorkbook.Worksheets.Count)
                 'コピーしたシートの名前をコピー元ブック名＆シート名に変更
                 'ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = TargetBook.Name & OriginalSheet.Name
                 'コピーしたシートの名前をコピー元シート名に変更
                 ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = OriginalSheet.Name
             Next
             '開いたブックを閉じる
             TargetBook.Close
             Set TargetBook = Nothing
         End If
         strBookName = Dir '次のファイル
     Loop
     Exit Sub
　ErrorHandler:
     'エラーが起きたら
 　   If Not (TargetBook Is Nothing) Then
  　      TargetBook.Close
   　 End If
     If Err Then
         MsgBox Err.Number & ":" & Err.Description, vbExclamation
         Err.Clear
 　   End If
 End Sub

（てつ）

コメント返信：

[ 一覧(最新更新順) ]

[[20050314145633]] 『数個のブックを1つにまとめたい』（ワケワカラン） ページの最後に飛ぶ

[[20050314145633]]　『数個のブックを1つにまとめたい』（ワケワカラン）　ページの最後に飛ぶ