• ベストアンサー
  • 困ってます

EXCELのVBAを使用してフォルダー内の複数のデーターの集計処理を

EXCELのVBAを使用してフォルダー内の複数のデーターの集計処理を 行いたいのですが1個目のデーター処理を行った後集計処理を行った後 集計シートを2個目のデーターに移動させたいのですが方法がわかりません。 下記のように集計表(原紙)を複数のデーターにコーピーはできるのですが Private Sub CommandButton1_Click() '集計表作成 Dim MyPath, MyBook, MyName MyPath = ThisWorkbook.Path & "¥" MyBook = ThisWorkbook.Name MyName = Dir(MyPath & "*.xls") Do While MyName <> "" If MyName <> MyBook Then Workbooks.Open Filename:=MyPath & MyName '一番左に集計表を貼り付ける Workbooks(MyBook).Worksheets(1).Copy Before:=Workbooks(MyName).Sheets(1) '"ここで集計処理後 次のBookへ移動" Workbooks(MyName).Save Workbooks(MyName).Close End If MyName = Dir Loop End Sub Copy部分をMoveにするとエラーメッセージがでてしまい 集計したシートを次々と移動させる方法がわかりません。 どのような方法で実行すれば宜しいでしょうか?

共感・応援の気持ちを伝えよう!

  • 回答数1
  • 閲覧数358
  • ありがとう数4

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.1
  • Wendy02
  • ベストアンサー率57% (3570/6232)

こんにちは。 >1個目のデーター処理を行った後集計処理を行った後 意味が良く分からないです。 データ処理を行うというという、「処理」は何ですか? マクロですか? >集計シートを2個目のデーターに移動させたいのですが方法がわかりません。 >集計したシートを次々と移動させる方法がわかりません。 マクロを乗せているブック(ThisWorkbook)のシート・データを、それぞれのブックにコピーするということは分かるのですが、その後、移動という言葉の意味が分かりません。マクロの「移動(Move)」という意味はは、ThisWorkbook のシートを別のブックに移動してしまうことですから、元がなくなってしまいます。だから、一回きりしかありません。それに、最後はエラーが発生します。すべてのシートを移動することは不可能です。 こういうことですか? Workbooks(MyBook).Worksheets(2).Copy Before:=Workbooks(MyName).Sheets(2) と、コピー元のシートの2番目のデータを、貼付け先のブックのシートの2番目にコピーする。 または、 'ただし、シートの順番が逆さになります。また、貼付け先のシート数が足らないと、エラーが発生します。 For i = 1 To ThisWorkbooks.Worksheets.Count   ThisWorkbooks.Worksheets(i).Copy Before:=Workbooks(MyName).Sheets(i) Next

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • VBA 探しているFileがないときの処理方法

    現在、下記のようにしてマクロ実行ブックと同じ階層のフォルダ名を取得してAに、フォルダ内のabc.XLSのC9の値をBに、abc.XLSの更新日時をCに表示させています。 このとき、フォルダ内にabc.XLSが無い場合にファイル名をAに書き出してB及びCは空白というように表示したいのですが、どのようにすればよろしいでしょうか。 macro1は以前質問させて頂いたものがベースになっています。ExecuteExcel4Macroを使っている関係でファイル名が無いときの処理はDirを使ってできるとmougで調べてわかりましたが、自分の知識ではできず、macro2を作成したのですが、指定ファイルがない場合の処理がうまくできずにいます。 macro1はファイルオープンの窓が開きます。macro2はファイルが存在しないという窓が開きます。 どちらの場合でもかまいませんのでお力をお貸し頂けませんでしょうか。 Sub macro1() Dim myPath As String Dim myFolder As String Dim r As Long r = 3 myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" Application.ScreenUpdating = False Range("A3:C60").Clear Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Cells(r, 1) = myFolder Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3") On Error Resume Next Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook) On Error GoTo 0 If Cells(r, 3) = "" Then Cells(r, 2) = "myBook" End If Cells(r, 2).NumberFormatLocal = "#,##0_ " Cells(r, 3).NumberFormatLocal = "y""年""m""月""" With Range("A3:C60") .Sort Key1:=Range("C3"), Order1:=xlAscending .Borders.LineStyle = True End With r = r + 1 End If End If myFolder = Dir() Loop Application.ScreenUpdating = True End Sub Sub Macro2() Dim myPath As String Dim myFolder As String Dim myBook As String myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" i = 2 Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Workbooks.Open (myPath & myFolder & "\" & myBook) Range("C9").Activate Selection.Copy ThisWorkbook.Activate Cells(i, 1) = myFolder Cells(i, 2).PasteSpecial xlValues Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook) Workbooks(myBook).Close SaveChanges:=False i = i + 1 End If End If myFolder = Dir() Loop End Sub

  • VBAにて複数フォルダのエクセルファイルからデータ抽出を行いたいのですが…

    現在、下記の方法で複数のブックからデータを抽出し、 一覧表示をしています。(一覧表示をしているブックを仮にAとします。) 今のままだと、同一フォルダ内のブックしか抽出されません。 これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか? 簡単に例をあげると、 フォルダ(1)の中にAを入れておいて フォルダ(1)の下にあるサブフォルダ(1)、サブフォルダ(2)の中にあるブックからデータの抽出を行いたいのです。 現在つかっているVBAは Sub 抽出用() Dim FName As String Dim Folder As String Dim wb As Workbook Dim i As Integer, j As Integer Application.ScreenUpdating = False Folder = ThisWorkbook.Path & "\" i = 1: j = 1 Worksheets(1).Cells.ClearContents FName = Dir(Folder & "*.xls") Do While FName <> "" If FName <> ThisWorkbook.Name Then Workbooks.Open (Folder & FName) Workbooks(Workbooks.Count).Worksheets(5).Rows("1:1").Copy _ ThisWorkbook.Worksheets(5).Cells(i + 3, 1) Workbooks(Workbooks.Count).Close Application.StatusBar = j & "ファイル処理済み" i = i + 1: j = j + 1 End If FName = Dir() Loop Application.StatusBar = "" Application.ScreenUpdating = True MsgBox ("完了しました") End Sub です。 いいお知恵があれば、よろしくお願い致します。

  • ExcelVBAでの転記処理エラーについて

    ExcelVBAを使用して、データを転記集約させる作業をしたいと思っています。 詳しく言いますと、同一のフォルダ内に各店からの注文書のファイルを保存し(フォーマットは同じ)、それを集計用のファイルで、それぞれ入力してあるデータを読み込み一覧にしていくという作業です。 転記部分をサブルーチンにしています。 実行すると、最後の topRng.PasteSpecial xlPasteValues でエラーになり、「実行時エラー1004 この操作には同じサイズの結合セルが 必要です」とメッセージが出ます。 そこで結合セルを解除したのですが、同じメッセージが出てしまいます。 どこをどう修正すればよいのか、お教え頂けないでしょうか? 転記先のセルの開始位置の取得が間違っているのでしょうか? 宜しくお願いいたします。 Dim keyRng As Range Sub 集計開始() myDir = "D:\集計用" flg = 0 ChDir myDir MyName = Dir(myDir & "\*.xls") Do While MyName <> "" Set mybook = Workbooks.Open(MyName) Call 転記(mybook.Sheets(1).Range("D6"), flg) flg = 1 Application.DisplayAlerts = False mybook.Close Application.DisplayAlerts = True MyName = Dir Loop Application.ScreenUpdating = True MsgBox ("集計処理が終わりました") End If End Sub Sub 転記(myRng, mytitle) Set keyRng = Range("A1") If keyRng = "" And keyRng.Offset(1) = "" Then Set topRng = keyRng Else Set topRng = keyRng.End(xlDown).Offset(1) End If Set mytbl = myRng.CurrentRegion If mytitle = 1 Then Set mytbl = mytbl.Offset(1, 0).Resize(mytbl.Rows.Count - 1, mytbl.Columns.Count) End If mytbl.Copy topRng.PasteSpecial xlPasteValues End Sub

  • Excel VBA連続コピー、貼付処理について

    特定のフォルダ内に格納されている複数のExcelファイルの「sheet1」シートのデータを 所定のExcelファイルにコピー&ペーストしたいのですが、うまくいきません。 (貼付先のファイルを閉じようとするとエラーが発生します。) どうすればできるようになるでしょうか? ご教授の程よろしくお願いいたします。 -------------------------------------------------------------------- Sub copy_test() Dim myPath As String Dim copyFile As String Dim pasteFile As String Dim n As Long myPath = "C:\copy\" copyFile = Dir(myPath & "*.xls*") pasteFile = "C:\paste\paste_data.xlsx" n = 2 Do Until copyFile = "" Workbooks.Open Filename:=myPath & copyFile Workbooks(copyFile).Worksheets("sheet1").Range("A2:L201").Copy Workbooks.Open Filename:=pasteFile 'Workbooks(pasteFile).Worksheets("paste_data").Active Range("B1").Select Selection.End(xlDown).Select Selection.End(xlToLeft).Select Selection.End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveSheet.Paste ActiveWorkbook.Save Workbooks(pasteFile).Close False Application.CutCopyMode = False Workbooks(copyFile).Close False n = n + 999 copyFile = Dir() Loop End Sub ---------------------------------------------------------------------------------

  • エクセルVBAでConsolidate

    以下は、ネット検索で見つけたサンプルコードです。 同じフォルダ内の全ブックのSheet1のA1:B10をThisWorkbookのSheet1に統合しています。 Sub test2() Dim MyFile As String, MyPath As String Dim SumFile() As Variant, i As Long MyPath = ThisWorkbook.Path & "\" MyFile = Dir(MyPath, vbNormal) Do Until MyFile = "" If MyFile <> ThisWorkbook.Name Then ReDim Preserve SumFile(i) 'A1からB10の値を変数に代入 SumFile(i) = "'" & MyPath & "[" & MyFile & "]Sheet1'!R1C1:R10C2" i = i + 1 End If MyFile = Dir Loop If i = 0 Then MsgBox "データが有りません": Exit Sub Worksheets("Sheet1").Range("A1").Consolidate Sources:=SumFile() End Sub 質問1 Sheet1だけでなく全シートのA1:B10をThisWorkbookのSheet1に統合するためにはどう書き換えればよいのでしょうか? 質問2 上記コードではなぜ、ブックを開かずにデータがとれるのでしょうか?

  • 各ブックの集計値を自動的に他のブックに総合計として表示させたい。

    エクセルで各ブックの集計値を他のブックに集計したいのですが、フォルダを移動させると数値が違ってしまう。どうすればいつ見ても正しい集計値を見れるか教えて下さい。 現在1つのファイルの中にある、ブック1・2・3にそれぞれ数値を入力して合計値をブック3の別シートに合計表示させていますが、同じブックのシート間の集計ではないため、毎回数値が変わってしまい、その都度計算式を(=ブック1 D60+ブック2 d80+・・・など)を入れなおしています。 間違いなく集計できる方法を教えて下さい。ちなみに全くの初心者なので細かく説明していただけると有難いです。 VBAで検索して下記を見つけ、セル範囲やシート名など変更して試してみましたが、内容がよくわからないため 変な数字がでてきました。初心者にはやはり無理でしょうか? Sub Test() Dim MyName As String, wb As Workbook On Error Resume Next MyName = Dir(ThisWorkbook.Path & "\*.xls", vbNormal) Do While MyName <> ""   If UCase(MyName) <> UCase(ThisWorkbook.Name) Then    Application.ScreenUpdating = False    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & MyName)    ThisWorkbook.Worksheets("Sheet1").Range("A65536").End(xlUp) _      .Offset(1, 0).Value = wb.Worksheets("物件").Range("d90:k90").Value    wb.Close   End If   MyName = Dir Loop Application.ScreenUpdating = True End Sub

  • 複数のエクセルファイルとシートからデータ抽出したい

    以前に http://soudan1.biglobe.ne.jp/qa8369459.html でやられている内容なのですが、私の場合はシートすべての[i4」のセル値を一覧でひっぱりたいです。 keithinさんご回答の sub macro1()  dim myPath as string  dim myFile as string  dim w as worksheet  mypath = thisworkbook.path & "\"  myfile = dir(mypath & "*.xls*")  application.screenupdating = false  do until myfile = ""   if myfile <> thisworkbook.name then    workbooks.open mypath & myfile    for each w in workbooks(myfile).worksheets    with thisworkbook.worksheets("Sheet1").range("A65536").end(xlup).offset(1)     .value = myfile     .offset(0, 1) = w.name     .offset(0, 2).value = w.cells(w.rows.count, "C").end(xlup).value              ↑をRange("i4").Value      end with    next    workbooks(myfile).close false   end if   myfile = dir()  loop  application.screenupdating = true end sub にて実施しましたが、ファイル名・シート名は正確に抽出するものの 参照したい「i4」のデータが先頭のシートのi4だけを拾ってしまいます 1.xls、2.xls、3xlsがありそれぞれ名前がばらばらなシート「あ」、「い」、「う」の3つがある。2.xlsには「え」、「お」、「か」のしーとがあると仮定、マクロを実行すると、一覧のエクセルに 1、xls  あ  あのシートi4の値 1、xls  い  あのシートi4の値 1、xls  う  あのシートi4の値 2.xls  え  えのシートi4の値 2.xls  お  えのシートi4の値 2.xls  か  えのシートi4の値 子のようなか形で出力されます い のところには いのシートのi4が、う のところには うのシートのi4が、 抽出されるには構文をどう買えればよいのでしょうか

  • VBA 簡潔なコードを書くために

    現在、下記のようなコード書いて利用しています。 このコードを他の人がに転用する時に、指定箇所さえ書き換えれば簡単に転用できる!と言うようにしたいのです。 例えば >Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName) >Set Copydata = SH1.Range("Z1").Resize(100, 1) といった指定するような箇所(" "で囲った所)を先にまとめて定義しておくにはどう記述したらよいのでしょうか。 宜しくお願いします。 ------------------------------------------------------------- Private Sub 読込ボタン_Click() '他のBookからデータを転記するマクロ Dim SH2 As Worksheet, SH1 As Worksheet Dim GYO As Range, Copydata As Range Dim myDir As String, myName As String, myBook As Workbook Set SH2 = ThisWorkbook.Worksheets("情報シート") '集計用のBookがあるフォルダ名を指定(このBookを格納している場所) myDir = ThisWorkbook.Path '他Bookのファイル名を指定(*.xls) myName = Dir(myDir & "\" & "*.xls") Do While myName <> "" 'このBook以外を対象 If myName <> ThisWorkbook.Name Then '転記先[情報シート]の最終行を取得 Set GYO = SH2.Range("A65536").End(xlUp).Offset(1) '他のBookを開いて変数に格納 Set myBook = Workbooks.Open(Filename:=myDir & "\" & myName) '転記元を取得(Z列1行を基点に100行コピー) Set SH1 = myBook.Worksheets("回答内容") Set Copydata = SH1.Range("Z1").Resize(100, 1) '転記先の最終次行に転記(行列入替で貼付) Copydata.Copy GYO.PasteSpecial Paste:=xlPasteValues, Transpose:=True '開いた他Bookを閉じる myBook.Close End If myName = Dir() Loop End Sub -------------------------------------------------------------

  • VBA コピペの途中でエラーになってしまいます。

    以前、質問させて頂き、マクロでしたい事の記述方法を教えて頂きました。 ご教示頂いたマクロ記述に更に手を加えて、下記のように記述しました。 したいことは、一つのフォルダにExcel Bookが120ほどあり、その中のマクロを組んだ集計用Book以外のBookから同じ名前のシート”結果”をコピーして、コピペされたシートは1、2、3・・という名前にして集計用Bookに値貼り付けをする。。というものです。 ところが、下記のマクロを実行するとシート名25までコピペされるのですが、途中で ”問題が発生したため MICROSOFT OFFICE EXCELを 終了します。・・・・・” とエラーになってしまいます。 このエラーを回避して120ほどあるシートをマクロのある集計Bookへコピペするには、どのようにしたら良いでしょうか? ご存知の方がみえたら、ご教示下さい。宜しくお願いいたします。 <マクロの記述> Sub macro() Const Aフォルダ As String = "C:\Documents and Settings\Bic\デスクトップ\Aフォルダ\" Dim FileCounter As Integer Dim myName As String myName = Dir(Aフォルダ & "*.xls") FileCounter = 0 Application.ScreenUpdating = False Do While myName <> "" If myName <> ThisWorkbook.Name Then Application.DisplayAlerts = False Workbooks.Open Aフォルダ & myName On Error Resume Next Workbooks(myName).Worksheets("結果").Copy After:=ThisWorkbook.Worksheets(2 + FileCounter) If Err.Number = 0 Then ActiveSheet.Range("A1:L35").Copy ActiveSheet.Range("A1:L35").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False FileCounter = FileCounter + 1 ActiveSheet.Name = FileCounter End If On Error GoTo 0 Workbooks(myName).Close End If myName = Dir Application.DisplayAlerts = True Loop Application.ScreenUpdating = True End Sub

  • エクセルVBAで、ある条件の時

    お世話になります。 エクセルVBAで次のようなことをしたいのですが方法を教えてください。 formフォルダにあるすべてのファイルについて、A1セルが「0」でないとき、 A4:B7及びA9:B12の中で日付が入っている行の日付と内容を、ActiveWorksheetのB列、C列にレコードとして取り出したいのです。 (A列はナンバリングになります) --------formフォルダの中にあるブック---------   A  B 1 23 2 3 日付 内容   'この行は固定です 4 5/13 あああ 5 5/17 いいい 6 7 8 日付 内容   'この行は固定です 9 5/16 ううう 10 5/12 えええ 11 12 5/10 おおお ---ThisWorkbook(前に助けていただいたコードです)--- Sub data_torikomi2()   Dim wb As Workbook   Dim Fn As String   Dim myPath As String   Dim dbBkSh As Worksheet   Dim i As Long   For Each wb In Workbooks     If wb.Name <> ThisWorkbook.Name And _     InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索       wb.Close '閉じる     End If   Next wb   myPath = ThisWorkbook.Path & "\"   Set dbBkSh = ThisWorkbook.Worksheets("一覧表")          Range("4:1000").Clear '全データ削除   Fn = Dir(myPath & "form\*.xls")   i = 1   '画面のちらつきを抑える   Application.ScreenUpdating = False   Do Until Fn = ""     If Fn <> ThisWorkbook.Name Then       With Workbooks.Open(myPath & "form\" & Fn, , True)         dbBkSh.Range("A3").Offset(i, 0).Value = i     【★たぶんこの部分に入るものです★】         .Close False         i = i + 1      End With     End If     Fn = Dir()   Loop   Application.ScreenUpdating = True   Set dbBkSh = Nothing End Sub ご教示よろしくお願いします。