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

複数のファイルのsheet1だけをまとめるには

sub UsedRangeをOffsetする() Dim rng先 As Range Dim PathMacrobook As String Dim Name元book As String Dim 元Book As Workbook Dim 元Sheet As Worksheet Set rng先 = Workbooks("BOOKALL.xls").Worksheets(1).Range("A2") PathMacrobook = ThisWorkbook.Path & "\" Name元book = Dir(PathMacrobook & "*.xls") Do While Not Name元book = "" If Name元book = ThisWorkbook.Name Then ElseIf Name元book = "BOOKALL.xls" Then Else Set 元Book = Workbooks.Open(PathMacrobook & Name元book) For Each 元Sheet In 元Book.Worksheets With 元Sheet.UsedRange .Offset(1).Copy rng先 Set rng先 = rng先.Offset(.Rows.Count - 1, 0) End With Next 元Book.Close False End If Name元book = Dir() Loop End Sub このコードではフォルダにあるブックのすべてのシートをBOOKALLのシート1に 上書きコピーしてしまう事がわかりました。 やりたい事 オープンするブックのsheet1だけを、.end(xlup)を使って一覧にしたいです。。 どの様にしたらよいでしょうか?

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

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

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

  • ベストアンサー
  • 回答No.1
  • onlyrom
  • ベストアンサー率59% (228/384)

>このコードではフォルダにあるブックのすべてのシートを、、 ----------------------------------------------------- ▲削除▲ For Each 元Sheet In 元Book.Worksheets ●挿入● Set 元Sheet = 元Book.Worksheets("Sheet1")    With 元Sheet.UsedRange     .Offset(1).Copy rng先     Set rng先 = rng先.Offset(.Rows.Count - 1, 0)    End With ▲削除▲ Next ------------------------------------------------ 上記のコードで、 ▲のFor、Nextを削除して、●のSetを入れる  

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

質問者からのお礼

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

関連するQ&A

  • VBA .WorksheetFunctionについて

    Dim DestBook As Workbook Dim pathmacrobook As String Dim namebook As String Dim myb As Range Dim r As Long Application.ScreenUpdating = False ThisWorkbook.Activate pathmacrobook = ThisWorkbook.Path & "\" & Worksheets("sheet1").Cells(1, 3).Value & "\" Set DestBook = Workbooks("残高集計用.xls") namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set myb = DestBook.Worksheets("sheet3").Range("A65536").End(xlUp) With Workbooks.Open(pathmacrobook & namebook) r = aplication.WorksheetFunction.MatchThisWorkbook.Worksheets("sheet1") .Range("C3:AH3"), namebook.Worksheets("sheet1").Range("C"), 0) If r > 0 Then .Close False Else With Workbooks.Open(pathmacrobook & namebook) .Worksheets("Sheet1").UsedRange.Offset(1).Copy myb.Offset(1)      lngREC = lngREC + 1 .Close False End With End If namebook = Dir() Loop Set DestBook = Nothing MsgBox lngREC & "日分" & "読込完了しました" 上記のコードについてですが、修飾子が不正です。や、 Loopに対するDoがありません等エラーが出てしまいます。 やりたい事は、"namebook"を開いた時、"Thisworkbook"のsheet3のC列に"namebook"のsheet1のC列があれば、 "namebook"閉じ、そうでなければコピーするというようにしたいです。 どなたかご教授お願いします。

  • excelvbaにてシート名を指定してコピーしたい

    いつもお世話になっております。 excel vbaにて、複数シートをひとつのbookにまとめようとしております。 シート名を指定してコピーしたいのですが、すべてのシートがコピーされてしまい困っています。 Worksheets("日帰り")だけを指定するには、どこの記述を変更したらいいでしょうか? どなたか教えてください。 ----------------------------------------------------------------- Sub C_SheetCopy() On Error GoTo ErrorHandler Dim strPath As String Dim strBookName As String Dim TargetBook As Workbook Dim TargetSheet As Worksheet 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) '開いたブックの全てのシートを処理 Set TargetSheet = TargetBook.Worksheets("日帰り") For Each TargetSheet In TargetBook.Worksheets '開いたブックのシートを自身の最後にコピー TargetSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 'コピーしたシートの名前をコピー元ブック名&シート名に変更 ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = TargetBook.Name & TargetSheet.Name Next '開いたブックを閉じる TargetBook.Close Set TargetBook = Nothing End If strBookName = Dir '次のファイル Loop 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

  • EXCEL2000とEXCEL2003のVBAについて

    現在、EXCEL2000で下記のコードを実行しています。 が、EXCEL2003で実行すると、 .UsedRange.Copy myb のコードが実行されているのにコピー出来ていません。 ファイルは開いていて、エラーは出ていないのです。 問題点わかる方教えていただけますか? Sub 日別データ読込() Dim rngsaki As Range Dim pathmacrobook As String Dim namebook As String Dim motobook As Workbook Dim myb As Variant Set rngsaki = Workbooks("残高集計用.xls").Worksheets(3).Range("a2") pathmacrobook = ThisWorkbook.Path & "\CSV読込データ12\" namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set motobook = Workbooks.Open(pathmacrobook & namebook) Set myb = Workbooks("残高集計用.xls").Worksheets(3).Range("A65536").End(xlUp) With motobook.Worksheets("Sheet1") .UsedRange.Copy myb End With motobook.Close False namebook = Dir() Loop MsgBox "完了しました" End Sub

  • VBAで別ブックを複数列検索し、隣のセルの値を取得

    book2(master)のセルA1、2、3・・・・の値でbook1(data)の任意の複数列(以下では3列目、8列目としています)を検索し、検索結果の右側のセルの値(以下の例の場合4列目と9列目)をbook2(master)の検索元セルの右側に書き込みたいのですが、実行すると実行時エラー1004アプリケーションまたはオブジェクトの定義エラーです。 と表示されてしまいます。回避方法について教えて頂けますでしょうか また、複数列の検索方法について適切な方法がありましたら教えて頂けますでしょうか 例) master A2”aa” 空欄 ←hoを取得 A3”bb” 空欄 ←3aを取得 A4”cc” 空欄 data(ランダムに配置されています) 1 2 3 4 5 6 7 8 9    ca de      d4 2f    c1 3a      bb 3a    aa ho      7e ee Sub kensaku() Dim book1 As Workbook Dim book2 As Workbook Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim rng As Range Dim r As Long Set book1 = Workbooks.Open("D:\Book1.xls") Set book2 = Workbooks.Open("D:\Book2.xls") Set sheet1 = book1.Sheets("data") Set sheet2 = book2.Sheets("master") r = 2 Do While sheet2.Range("A" & r).Value <> "" Set rng = sheet1.Range(Columns(3), Columns(8)).Find(sheet2.Range("A" & r).Value, LookAt:=xlWhole) If Not rng Is Nothing Then sheet2.Range("B" & r).Value = rng.Offset(0, 1).Value End If r = r + 1 Loop End Sub

  • AccessでExcelのSheet間のコピーをしたい

    ACCESSのデータを読み込み、エクセルの元帳からレイアウトをコピー、新しいExcelのSheetにレイアウトとデータを書き込もうとしていますがうまく動きません。どこが悪いのでしょうか?次のように書きました。 Private Sub NEW_BOOK() Dim xlBookOrig As Workbook Dim xlBookNew As Workbook Dim xlSheetOrig As Worksheet Dim xlSheetNew As Worksheet Set xlApp = CreateObject("Excel.Application") xlApp.Application.Visible = True Set xlBookOrig = xlApp.Workbooks.Open("C:\元帳.xls") Set xlSheetOrig = xlBookOrig.Worksheets(1) Set xlBookNew = xlApp.Workbooks.Add Set xlSheetNew = xlBookNew.Worksheets(1) xlSheetOrig.Copy xlSheetNew.Paste xlSheetNew.Name = Left$(strMODL, 9) xlSheetNew.Cells(5, 1).Value = strSTAT xlSheetNew.Cells(4, 3).Value = strITEM ..... xlSheetNew.SaveAs "C:\'" & Left$(strMODL, 7) & "'.xls" これで実行すると、BOOK1 BOOK2 の2つが生成され、 BOOK1にはSHEET名、各データが書き込まれ、BOOK2には元帳のレイアウトがコピーされレイアウトとデータが一つになりません。 どこが間違っているのでしょうか? 宜しくお願いします

  • Book1.xlsとBook2.xlsのエクセルファイルが有ります。

    Book1.xlsとBook2.xlsのエクセルファイルが有ります。 VBAを作成しているのはBook2.xlsで操作しています。 Book1 Sheet1 A B C 1 6 4 2 2 8 5 3 3 5 1 4 . Book1のシートのB列とC列には整数が入力されています。 A列には計算式が入ります。 例)A1の計算式 =B1+C1 A2の計算式 =B2+C2 A列の結果をBook2 Sheet1 のA列に反映しようとした場合に、 以下のVBAだと、計算式のコピーになってしまうので、計算結果の値を反映する事が出来ません。 A列の計算結果(上記の例だと、6,8,5)をまとめて反映させる方法はありますか? Sub tashizan() Dim thisBook As Workbook Dim workBook1 As Workbook Set thisBook = ThisWorkbook Set workBook1 = Workbooks.Open("C:\Documents and Settings\Book2.xls") thisBook.Worksheets("Sheet1").Range("A1:A100").Copy workBook1.Worksheets("Sheet1").Range("A1") workBook1.Close End Sub 初心者ですので、宜しくお願いします。

  • VBAでsheetのコピー

    ご回答有難う御座いました。補足説明を致します。動作するとこまでは、出来たのですが、一点変更しました。:=のコピーの所でデバッグすると、エラーになるので、=だけにしました。すると動作するのですが、新しいsheetの名前が、コピー元のsheet名になります。そして、MsgBoxを入れると、エラーになります。また、1sheetだけがコピーされます。大変恐縮ですが、もう一度ご教授願います。補足説明なりますが、やりたい事は、拡張子がxlsmの中に名前のついた10個のsheetがあります。この10個のsheetを拡張子がxlsxのBookにコピーしたいのですが、このBook1のsheetをVBAから新に作成しBook2のsheet1に纏めたいのですが、纏め方は、Book2のsheet1の下から上に10sheetをコピーして、条件としてBook2のsheet1の名前は、固定で構いません。Book1の一番初めのsheetにコピーする時だけ3行目にある見出しだけは、Book2のsheet1に付けたく。それ以外のBook1のsheetは、デターだ4行目以降をコピーしたいのですが、また、コピーしたいsheetの範囲に列は、A1~AFで列は3~62までです。マクロはご教授頂いた、下記通りです。 Sub macro1() Dim i As Long Dim w0 As Workbook Dim s As Worksheet Set w0 = ActiveWorkbook '1枚目シートから貼り付け先のブックを作る w0.Worksheets(1).Copy Set s = ActiveSheet '2枚目以降のデータをコピーする For i = 2 To w0.Worksheets.count With w0.Worksheets(i) .Range("A4:AF" & .Range("A65536").End(xlUp).Row).Copy Destination = s.Range("A65536").End(xlUp).Offset(1) End With Next i End Sub これを先ほど書きました、マクロを教えて頂けませんでしょうか?何せ、マクロ初心者なので、msm相談箱がたよりです。何卒マクロを教えて頂きたく宜しくお願い申し上げます。

  • VBAのオブジェクト変数について

    人に教えなければいけないことなので、、、 困っています。 あるVBAのテキストを見て、そのテキストをそのまま入力しても実行できません。 (条件としては、Book1.xlsとBook2.xlsというファイルを開いた状態で、Book1.xlsのほうに、以下のモジュールを入力します。) Sub Set1() Dim myBook As Workbook Dim mySheet As Worksheet Dim myCell As Range Set myWBook = Workbooks("Book2.xls") Set myWSheet = Worksheets("Sheet2") Set myCell = Range("A1:D10") myWBook.Activate myWSheet.Activate myCell.Value = "ABC" End Sub これを実行すると、アクティブな状態のファイルにしか、値"ABC"が入ってこないのです。テキストでは、Book2.xlsのSheet2のA1:D10に値"ABC"が入ってくると言っていますが、Book1.xlsに値が入ってしまったりします。 長くなってしまってすみません。 もちろん、他の方法で実現することができるのはわかるのですが、なぜこのコードが実行できないのかがわかりません。 理由を教えていただけたら・・・と思います。 よろしくお願いいたします。

  • エクセルVBA 数式の中に、変数で定義したシート名を入力するには

    いつもお世話になります。 =SUMPRODUCT(('[BOOK1.xls]SHEET1!$D$20:$D$1000=$E$4)*('[BOOK1.xls]SHEET1!$D$20:$D$1000!$O$20:$O$235>=$B9)*('[[BOOK1.・・・ という長い数式を、VBAに書き込みたいのですが、関数が長すぎるせいか、書き込めません。 そこで、 Dim SH1 As Worksheet SET SH1 = Workbooks("BOOK1.xls").Worksheets("SHEET1") として、[BOOK1.xls]SHEET1!をSH1に省略したいのですが、どのように数式に組み込めば良いでしょうか。

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

    以前に 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が、 抽出されるには構文をどう買えればよいのでしょうか