[[20140921120523]] 『ネットワーク内のフォルダのブックの統合』(pepsiman) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『ネットワーク内のフォルダのブックの統合』(pepsiman)

ネットワーク内のフォルダに有るブック(約20個)の一つのシートをデータ行を、1つの新規ブックにまとめたいと思っています。
過去の質問[[20100220200243]]を参考にし、作成していたのですが、VBA初心者の為いまいち理解出来ず…
分かる方の知恵をお借りできればと思い、こちらにて質問させて頂きました。

・ネットワーク内のフォルダに有るブックは3行目からデータ行となっており、行数・列数はまちまち
・ネットワーク内のフォルダに有るブックはそれぞれ1つしかシートがありません。
・項目はA列からM列くらいまでコピーしたいと考えています。(項目の並びは同じで、いくつかのブックは項目数が多いですが、最大でM列くらいまでしかデータは無いのでM列までコピー出来れば問題ないかと思います。)
・フォルダ内にはxls、xlsxの双方があり、どちらも1シートに統合し、DBブックとして保存したいです。

宜しくお願い致します。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 こんなのを動かしてみたらどうなりますか?

 '------
Sub ブックを統合02()
    Dim seDir As String, myDir As String, myFileName As String
    Dim wb As Workbook, ws As Worksheet
    Dim mxRow As Long, myRow As Long
    With ActiveSheet
        If MsgBox("処理を開始します。現在のシートのデータは削除されます。", _
                    vbOKCancel + vbExclamation) = vbCancel Then
            Exit Sub
        End If
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                seDir = .SelectedItems(1)
            End If
        End With
        If seDir = "" Then
            MsgBox "処理を中止します。"
            Exit Sub
        End If
        .Range("4:" & Rows.Count).Clear
    'Application.ScreenUpdating = False
            myDir = seDir & "\"
            myFileName = Dir(myDir & "*.xls")
            Do While myFileName <> ""
                 Set wb = Workbooks.Open(myDir & myFileName)
                 Set ws = wb.Sheets(1)
                    mxRow = ws.Range("A" & Rows.Count).End(xlUp).Row
                    If mxRow > 2 Then
                        If myRow = 0 Then
                            .Range("A1").Value = "ブック名"
                            ws.Range("A1:M1").Copy .Range("B1")
                        End If
                        .Range("A" & myRow + 1).Resize(mxRow - 2, 1).Value = Mid(myFileName, 1, Len(myFileName) - 4)
                        ws.Range("A2:M" & mxRow).Copy .Range("B" & myRow + 1)
                        myRow = myRow + mxRow - 2
                    End If
                    wb.Close False
                myFileName = Dir
            Loop
        .Range("B2:B" & mxRow).Copy
        .Range("A2").PasteSpecial Paste:=xlPasteFormats
        .Range("A1").Select
        Application.CutCopyMode = False
    'Application.ScreenUpdating = True
    End With
End Sub
 '------

 動かしてみてないので、よく確認して
 問題個所を教えて下さい。
  
(HANA) 2014/09/21(日) 14:00

各ブックの3行目からデータを抽出したいのですが、出来ていないようです。また、最初に記載し忘れていましたが、抽出後は5行目あたりから表示させたいです。
そして、xlsxブックの抽出が出来ていないようです。(抽出自体は頂いたVBAを真似たので出来るのですが、xlsブックの抽出が出来た後、すぐ下にxlsブックの抽出を始める方法がわかりません、、、)

お手数ですが、宜しくお願い致します。
(pepiman) 2014/09/25(木) 16:31


 まずは
 >各ブックの3行目からデータを抽出したい
 >xlsxブックの抽出が出来ていないようです。
 の2点に関してですが
                        .Range("A" & myRow + 1).Resize(mxRow - 2, 1).Value = Mid(myFileName, 1, Len(myFileName) - 4)
                        ws.Range("A2:M" & mxRow).Copy .Range("B" & myRow + 1)
 の所を
                        .Range("A" & myRow + 1).Resize(mxRow - 2, 1).Value = myFileName
                        ws.Range("A3:M" & mxRow).Copy .Range("B" & myRow + 1)
 にしてやって結果をかくにんしてみてもらえますか?

 A列にブック名が、拡張子まで含めて入る様になっています。
 xlsブックもxlsxブックも 混ざって抽出されると思いますが。
  
(HANA) 2014/09/25(木) 16:39

数か所修正したら動きました。
ありがとうございました。
(pepiman) 2014/10/10(金) 11:44

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.