• 締切済み

複数のブックコピーの繰り返しその２

　このサイトのお力により以下のプロシージャができました。 折角作っていただいたのですが、処理枚数が増えたため１ファイルに1日分だったのが３日分（６ファイル）をコピーすることになってしまいました。どのようにしたらよいでしょうか、お分かりの方いらっしゃいましたらよろしくお願いします。 　現状は、あるフォルダー内のファイル970303日報1、970303日報2を開いて、新しいブックに貼りつけて保存する。次に970304日報1、970304日報2を開いて新しいブックに貼りつけて保存するという作業の繰り返しです。 　これを、970303日報1,2　970304日報1,2　970305日報1,2の3日分を新しいブックにコピーして保存する。次に970306日報1,2　970307日報1,2　970308日報1,2を新しいブックにコピーして保存する。これの繰り返しをしたいのですがどうしたらよいでしょうか。 　ファイルのコピーする範囲は一定です。貼り付けるブックのセルは １日目の日報１がA1、日報2がL5、2日目の日報1がA40、日報2がL44 3日目の日報1がA79、日報2がL83となります。 　すみませんよろしくお願いします。 Sub copybook11() Dim myPath As String 'このブックのパス Dim DataFile As String 'Dir()で開くブック名 Dim copybook As Workbook '開いたブック Dim NewBook As String '新しいブック Dim NewFileName As String '新しいファイル名 myPath = ThisWorkbook.Path & "\" DataFile = Dir(myPath & "*.xls", vbNormal) Do While DataFile <> "" If DataFile <> ThisWorkbook.Name And InStr(1, 　　　　DataFile, "日報") > 0 Then Set copybook = Application.Workbooks.Open 　　　　(Filename:=myPath & DataFile, ReadOnly:=True) Select Case Mid(DataFile, InStr(1, DataFile, "日 　　　　　報"), 3) Case "日報1" Workbooks.Add NewBook = ActiveWorkbook.Name copybook.ActiveSheet.Range("A1:K38").copy Workbooks(NewBook).ActiveSheet.Range 　　　　　　　　　　("A1").PasteSpecial paste:=xlAll Application.CutCopyMode = False copybook.Close Case "日報2" copybook.ActiveSheet.Range 　　　　　　　　　　("B3:K36,T3:U36").copy Workbooks(NewBook).ActiveSheet.Range 　　　　　　　　　　("L5").PasteSpecial paste:=xlAll Application.CutCopyMode = False copybook.Close NewFileName = Format(Workbooks 　　(NewBook).ActiveSheet.Range("k2").Value, "yyyymmdd") & "日 　　　報.xls" Workbooks(NewBook).SaveAs Filename:=myPath 　　　　　　　　　　& NewFileName, FileFormat:=xlExcel8 Application.DisplayAlerts = True Workbooks(NewFileName).Close End Select End If DataFile = Dir Loop End Sub

みんなの回答

  • hige_082
  • ベストアンサー率50% (379/747)
回答No.1

前回の解決から、数日で変更ですか ご自分でも分っていると思いますが 初心者には、まだ難しいと思いますよ 必要ならば、専門業者にでも頼んでは如何？ 変更部分のみ Case "日報1" If NewBook Is Nothing Then copybook.ActiveSheet.Copy Set NewBook = ActiveWorkbook Else With NewBook.ActiveSheet copybook.ActiveSheet.Range("A1:K38").Copy .Range("A40") If .Range("a40").Value = "" Then .Range("a40").PasteSpecial Paste:=xlAll Else .Range("a79").PasteSpecial Paste:=xlAll End If End With End If copybook.Close Case "日報2" With NewBook.ActiveSheet copybook.ActiveSheet.Range("B3:K36,T3:U36").Copy If .Range("l5").Value = "" Then .Range("L5").PasteSpecial Paste:=xlAll ElseIf .Range("l44").Value = "" Then .Range("L44").PasteSpecial Paste:=xlAll Else .Range("L83").PasteSpecial Paste:=xlAll copybook.Close NewFileName = Format(.Range("k2").Value, "yyyymmdd") & "日報.xls" NewBook.SaveAs Filename:=myPath & NewFileName, FileFormat:=xlExcel8 Application.DisplayAlerts = True NewBook.Close End If End With エラー等は考慮していません 最低限の変更しかしてませんので・・悪しからず

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. その他MS Office製品

関連するQ&A

  • エクセルで複数ファイルコピー保存

    こういうことがやりたいです。 １、新規ブック作成　２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。 　日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。 　前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。 　初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。 Sub copybook7() Dim myPath As String 'このブックのパス Dim DataFile As String 'Dir()で開くブック名 Dim copybook As Workbook '開いたブック Dim DataSht As Worksheet 'このブックの貼り付けシート Dim i As Long '貼り付け行カウンタ Workbooks.Add With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With With ActiveSheet.PageSetup Range("A1:G1,L1:AG1").ColumnWidth = 9 Range("H1:K1,AH1").ColumnWidth = 12 End With With ThisWorkbook Set DataSht = .Worksheets(1) myPath = "C:\1997\" DataFile = Dir(myPath & "*.xls", vbNormal) i = 1 Do While DataFile <> "" If DataFile <> .Name And _ InStr(1, DataFile, "日報") > 0 Then Set copybook = Application.Workbooks.Open( _ Filename:=myPath & DataFile, ReadOnly:=True) If InStr(1, DataFile, "日報1") > 0 Then copybook.ActiveSheet.Range("A1:K38").Copy DataSht.Range("A1").PasteSpecial Paste:=xlAll ElseIf InStr(1, DataFile, "日報2") > 0 Then copybook.ActiveSheet.Range("B3:K36").Copy DataSht.Range("L5").PasteSpecial Paste:=xlAll Else End If Application.DisplayAlerts = False copybook.Close SaveChanges:=False Application.DisplayAlerts = True Set copybook = Nothing End If DataFile = Dir ActiveWorkbook.SaveAs Filename:=ActiveSheet.Range("K2") & "日報" .Close Loop Set DataSht = Nothing End With End Sub

  • フォルダ内の特定ブックだけを1つのブックにまとめる

    以前こちらで質問させて頂きましたフォルダ内の特定ブックだけを1にのブックにまとめる方法で、大変助かっていましたがブック名が変更になり、教えて頂いたマクロでは実行できなくなったので自分なりに考えたのですがどうしてもできません。 質問時のブック名は「1_****」と「2_****」で 今回「1_****」だけが「1(3)_****」に変更になりました。 下記のマクロでmyfile = dir(mypath & "1_" & "*.xl*")→myfile = dir(mypath & "1(3)_" & "*.xl*")に変更するのはわかるのですが do until myfile = "" 　　myfile2 = "2" & mid(myfile,2,99)をどう変更すれば良いかわかりません どなたかお助け頂けませんか？ sub macro1() 　dim myPath as string 　dim myFile as string 　dim myFile2 as string 　mypath = "c:\test\" 　myfile = dir(mypath & "1_" & "*.xl*") 　do until myfile = "" 　　myfile2 = "2" & mid(myfile,2,99) 　　workbooks.open mypath & myfile 　　workbooks.open mypath & myfile2 　　application.displayalerts = false 　　workbooks(myfile).worksheets("2").delete 　　application.displayalerts = true 　　workbooks(myfile2).worksheets("2").move after:=workbooks(myfile).worksheets("1") 　　workbooks(myfile).close true 　　workbooks(myfile2).close false 　　myfile = dir() 　loop end sub

  • VBAでブック名の拡張子を除去してシートにコピー

    VBA初心者でコード作成で困っております。 下記の通りコードを組みましたが、シート名をブック名に変更して 保存したいのですが、このコードですと拡張子までついてしまいます。 拡張子を除去するためにはどうすればよいでしょうか？ アドバイス宜しくお願い致します。 Sub test() 'シート名の変更 Dim MyPath As String Dim MyFile As String Dim Wb As Workbook MyPath = "C:\TEST\" MyFile = Dir(MyPath & "*.xlsx") Do While MyFile <> "" Set Wb = Workbooks.Open(MyPath & MyFile) ActiveSheet.Name = ActiveWorkbook.Name Application.DisplayAlerts = False Wb.Save Application.DisplayAlerts = True Wb.Close (False) MyFile = Dir() Loop End Sub

  • 保護されたブックのコピーについて

    現在、ボタンを押すと新規ブックが作成され、最初のブックのシートをコピーするというマクロを組みました。 しかし、元になるブックにはブックの保護とシートの保護を両方かけていて、途中でエラーになるはずなのですが、何故かそうならずに普通に新規ブックにコピーがされます。 上手くいったのですがエラーが出ると予想していたので気持ちが悪く、また個人だけで使うわけじゃないので原因を知っておきたいです。 どなたかよろしくお願いします。 Private Sub makeBookButton_Click() Dim myWorkBook As String Dim newWorkBook As String Dim mySheet As Worksheet Application.ScreenUpdating = False On Error GoTo ErrTrap Application.DisplayAlerts = False myWorkBook = ThisWorkbook.Name Workbooks.Add ActiveWorkbook.SaveAs Filename:=NEWBOOK newWorkBook = ActiveWorkbook.Name Workbooks(myWorkBook).Activate For Each mySheet In ThisWorkbook.Worksheets Workbooks(myWorkBook).Sheets(mySheet.Name).copy after:=Workbooks(newWorkBook).Sheets(Workbooks(newWorkBook).Sheets.Count) Next Workbooks(NEWBOOK).Sheets("Sheet1").Delete Workbooks(NEWBOOK).Sheets("Sheet2").Delete Workbooks(NEWBOOK).Sheets("Sheet3").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True Exit Sub ErrTrap: Call MsgBox("ブック作成時にエラーが発生しました。", vbCritical) End Sub

  • ブックの選択について

    ブックの選択について 以下のように、マクロのあるブック意外のブックを開いて からマクロのあるブックを選択しようとしてもできません。 具体的には一番下の Workbooks(thisBook).Select が正常に動きません。 なぜでしょうか？ Dim myFName As String Dim macrobook As Object Dim thisBook As Workbook Set thisBook = ThisWorkbook myPath = ActiveWorkbook.Path ChDir myPath myFName = Dir("*S*.xls") Workbooks.Open Filename:=myFName Workbooks(myFName).Activate Worksheets(1).Select Workbooks(thisBook).Select

  • 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のDirをつかってブックを検索した後のことについて。

    VBAのDirをつかってブックを検索した後のことについて。 お世話になっております。 以下のコードでファイルを開いたものをアクティブにするにはどうすればよろしいでしょうか？ 流れ １）以下のコードでブックを開き、このブックのセルを検索、コピー ２）貼り付けブックを開いて貼り付け ３）もう一度以下のブックで開いたブックのセル検索、コピー ４）貼り付けブックに貼り付け 流れの３）でつっかかってます。 どうか宜しくお願い致します。 ///コード/// Dim myPath As String Dim myFile As String myPath = "C:\Documents and Settings\1234567\デスクトップ\棚卸" & "\" myFile = Dir(myPath & "*棚卸一覧表(1G).xls") If myFile <> "" Then Workbooks.Open Filename:=myPath & myFile Else MsgBox "ファイルは見つかりませんでした" End If

  • エクセルで複数のブックの一部を抽出する

    エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？ merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、 課名D16 商品名B20:B39 枚数H20:H39 金額I20:I39 の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？ もとのブックの行数は決まっています。 どうか力を貸してください。よろしくお願いします。 Sub test02() Dim MyFile As String, MyPath As String '変数宣言 Dim x As Long, y As Long Dim wb As Workbook, tb As Workbook Dim ka As String Dim sh1, sh2 Set tb = ThisWorkbook MyPath = tb.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル Application.ScreenUpdating = False '画面更新停止 Application.Calculation = xlCalculationManual '自動計算停止 Do While MyFile <> "" 'エクセルファイルがなくなるまで If MyFile <> tb.Name Then '自分以外のファイルを対象 Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く With ActiveSheet ka = .Range("D16").Value '課名取得 x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 sh1 = .Range("B20:B" & x).Value '商品名取得 sh2 = .Range("H20:I" & x).Value '数量＆金額取得 End With With tb.Sheets("Sheet1") y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 y = IIf(.Range("B" & y) = "", y, y + 1) If x >= 20 Then '納品書B20以下にデータがあれば Set myRng = .Range("A" & y).Resize(x - 19, 1) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = sh1 '商品名転記 myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記 End If End With wb.Close (False) '選択したファイルを閉じる End If MyFile = Dir() '次のファイルを検索 Loop '繰り返し Application.Calculation = xlCalculationAutomatic '自動計算停止解除 Application.ScreenUpdating = True '画面更新停止解除 Set tb = Nothing Set wb = Nothing Set myRng = Nothing End Sub

  • 複数のエクセルデータ上特定位置の値を一つのセルに２

    前回の質問「複数のエクセルデータ上特定位置の値を一つのセルに」に対し、ベストアンサーを教えていただきました。その質問とご回答のポイントは次の通りです。 質問： 大量の同じフォーマットのエクセルファイル（Book1,Book2...）があり、それぞれのBookファイルの「NO.」シートのD6セルには番号が入っています。それぞれファイルでSheet1の特定のセル（例えばB4セル）の値を「データ」ファイルのSeet1にまとめたいです。「データ」ファイルのA列には「NO.」が入力されているので、Bookファイルの値はそれぞれ対応する番号の右側3番目のセルに移したいです。 ご回答： sub macro1() 　dim myPath as string 　dim myFile as string 　dim myNo as variant 　dim myRng as range 　on error resume next 　application.screenupdating = false 　mypath = "c:\test\"　’book1,2,3…の保存場所を指定する事 　myfile = dir(mypath & "*.xlsx")　’拡張子を正しく指定すること 　do until myfile = "" 　　workbooks.open mypath & myfile 　　myno = workbooks(myfile).worksheets("No.").range("D6").value 　　set myrng = thisworkbook.worksheets("Sheet1").range("A:A").find(what:=myno, lookin:=xlvalues, lookat:=xlwhole) 　　myrng.offset(0, 3).value = workbooks(myfile).worksheets("Sheet1").range("B4").value 　　workbooks(myfile).close savechanges:=false 　　myfile = dir() 　loop 　application.screenupdating = true end sub 現在Excel2007を使っており、Bookファイルが全部(.xlsx)の状態では問題なく使えましたが、ファイルが97-2003の(.xls)バージョンになると、マクロを実行したときに次のメッセージが出ます。「データ.xlsmは既に開いています。2重に開くと、これまでの変更内容は破棄されます。データ.xlsmを開きますか?」 もちろんご回答の中の「myfile = dir(mypath & "*.xlsx")　’拡張子を正しく指定すること」は（"*.xls"）に変更されている状態です。 何が問題なのか全く分からず、困っています。どなたか教えていただけないでしょうか? よろしくお願い致します。

  • 複数ファイルのA1だけを抽出して別ファイルにしたい

    すみませんが、教えてください。 特定のフォルダ内に入っているcsvのA1列目のみ抽出して別ファイルにしたく、検索したところ 同じように困っていた方がいたようで、参考にさせていただいたのですが、 以下を実行しても インデックスが有効範囲にありませんと出ます。 各csvファイルのシート名は 1000近くあるファイル全て違い、別々の名前（コード00-000とか）になっています。 （エクセルで開いたとき） お手数ですが、教えていただきたくお願いいたします。 参考にしたマクロです。 Sub macro1() Dim myPath As String Dim myFile As String myPath = "ファイルの場所\" myFile = Dir(myPath & "*.xls") Do Until myFile = "" Workbooks.Open myPath & myFile With Workbooks("集約.xls").Worksheets("Sheet1").Range("A65536").End(xlUp) .Offset(1, 0).Value = myFile .Offset(1, 1).Value = Workbooks(myFile).Worksheets("概要").Range("C3").Value End With Workbooks(myFile).Close savechanges:=False myFile = Dir() Loop End Sub 宜しくお願いいたします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する