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

EXCEL VBAで別ファイル作成

エクセル97です。 エクセルファイル AAA.xls のすべてのワークシートのうち、セルA1に TRUE がはいっているもの、(枚数はそのときにより不定です。)のみをコピーして、別のエクセルファイルを作成したいのです。 その際、新しいファイルに貼り付けるのは書式と値のみで、シート名は 元ファイルのシート名と同じにしたいのです。 どのようなVBAを書けばよいかご教示ください。 (AAA.xls にはワークシート以外にグラフシートやダイアローグシートが入っています。)

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

  • 回答数7
  • 閲覧数958
  • ありがとう数7

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

  • ベストアンサー
  • 回答No.6
  • ja7awu
  • ベストアンサー率62% (292/464)

> ダイアローグシートが入っているとそこでエラーになるようです。 なるほど納得で~す。グラフだけで、これを入れないでテストしていました。 ダイアログって始めて操作しました。参考になった点があって良かったです。 >ワ-クシート以外のシートはコピー不要です。 そうだったんですか。最初に確認すべきでしたね。 今度は、大丈夫と思います。  Sub test() Dim NewObj As Workbook Dim Sh As Integer Dim Shn As String Dim Shc As Integer Dim N As Integer Set NewObj = Workbooks.Add Application.DisplayAlerts = False For Sh = 1 To ThisWorkbook.Worksheets.Count   ThisWorkbook.Activate   Shn = Worksheets(Sh).Name   If Worksheets(Sh).Range("A1").Value = True Then     Shc = Shc + 1     Worksheets(Sh).Cells.Copy     If Shc > NewObj.Sheets.Count Then       NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)     End If     NewObj.Sheets(Shc).Activate     Selection.PasteSpecial Paste:=xlValues     Selection.PasteSpecial Paste:=xlFormats     For N = 1 To NewObj.Sheets.Count       If NewObj.Sheets(N).Name = Shn Then         NewObj.Sheets(N).Delete         Exit For       End If     Next N     ActiveSheet.Name = Shn     ActiveSheet.Range("A1").Select   End If Next Sh NewObj.Sheets(1).Select NewObj.SaveAs "C:\bbb.xls" NewObj.Close Application.DisplayAlerts = True Set NewObj = Nothing End Sub  

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

質問者からのお礼

何度もすみません。今度はうまく行きました。有難うございます。 最後にもう一つだけ教えて下さい。 保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が任意で設定するためにはどうすればいでしょうか?

関連するQ&A

  • ExcelのVBAで、他のExcelファイルのセルのデータを取得

    ExcelのVBAで、他のExcelファイルのセルのデータをファイルを実際に開かずに取得する方法はありますか? Workboks.openを使わずに、具体的にどうすればいいのでしょう? (例)  AAA.xls のセル"C5"に BBB.xls のセル"B3"のデータを入力したい場合。 (AAA.xlsにマクロを起動するボタンがある) ただし、BBB.xlsの最初の3行は空白です。

  • 複数Excelファイルの一括インポートしたい。

    複数Excelファイルがあります。(aaa.xls、bbb.xls・・・) 同フォルダ内にあるExcelファイル(20個ほど)を1つのファイルにしたいのですが、 手動コピペ以外の方法を教えていただけますでしょうか? できれば、マクロ、VBAでお願いします。 ワークシート名はすべて同じです。(Sheet1のみ取り込みたい(無理であれば他も取り込みしてもOK)) 1つのファイル内で横に並べるようにしたいです。(ファイル名か、Sheet1_1,Sheet1_2・・・) よろしくお願いします。

  • EXCEL VBAを利用して別ウィンドウでブックを起動する

    エクセルファイル(A.xls)内のセル($A$1)をダブルクリックすることで、エクセルファイル(B.xls)のワークシート(1)を開くVBAを作成しています。 ここまでは出来たのですが、1つ問題があります。 上記VBAでは、A.xls と B.xls が1つのエクセルファイルとして開かれてしまいます。(表現が誤っていれば申し訳ないです) どういうことかと言いますと、A.xlsもしくは、B.xlsのどちらかを閉じると両方閉じてしまいます。また、A.xlsとB.xlsを画面上に並べて比較することができず、画面下のタブを切り替えてそれぞれのファイルを見なければなりません。 例えば、スタート→プログラム→MicroSoftOffice→EXCELを2回行えば、エクセルファイルが別ウィンドウでそれぞれ独立して立ち上がります。要は、A.xlsのセル($A$1)をダブルクリックした時にB.xlsはこのような状態で立ち上がってきて欲しいのです。 以下、作成途中のVBAコードの一部です。A.xlsのセル($A$1)をダブルクリックすると、独立したエクセルを開くことはできました。 Dim OP As Double   OP = Shell("EXCEL.EXE", vbMaximizedFocus) しかし、B.xlsのワークシート(1)はA.xlsと1つのファイルとして開かれてしまいます。 (例:A.xlsのセル($A$1)をダブルクリックすると、B.xlsと新規EXCELファイルの全部で3つの状態になります。) 目標は、A.xlsのセル($A$1)をダブルクリックすれば、B.xlsのワークシート(1)が開く。 A.xlsのセル($B$2)をダブルクリックすれば、B.xlsのワークシート(2)が開くです。 長くなりましたが、どうかご助言よろしくお願い致します。 【作成途中VBAコード】 Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean) Dim OP As Double    Dim Bfile As String Bfile = target.Address Select Case Bfile Case "$A$1" OP = Shell("EXCEL.EXE", vbMaximizedFocus) Workbooks.Open ("C:\B.xls") Worksheets("ワークシート(1)").Activate Case Else End Select End Sub

その他の回答 (6)

  • 回答No.7
  • ja7awu
  • ベストアンサー率62% (292/464)

> 保存する時の保存場所、および新しいファイルの名前はそのとき操作する人間が > 任意で設定するためにはどうすればいでしょうか? 具体的にどの時点で、どのような方法で指定したいのかが分からないので、 いろいろな方法があって、いちがいには言えません。 まぁ、操作性が良いのではないかと思われる方法として、セルA1に TRUE と入力 した一番左側のシートで、セルA2とかに フォルダ名を、A3にファイル名を記述する 方法ですね。 フォルダ名、ファイル名とも幾つか選択するような状況なら、コンボボックスで リストから指定するようにすれば良いでしょう。 あとは、マクロ起動時、ダイアログを出して、入力する方法もあります。 ただ、既設のホルダ名でないといけませんので、その辺をチェックするコードが 必要になるでしょう。

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

質問者からのお礼

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

  • 回答No.5
  • ja7awu
  • ベストアンサー率62% (292/464)

Excel97 SR-1 で確認しましたが、正常に動作します。 イミディエイトウィンドウに下記のように記述すると 3とか -4167 の 数字が返りませんか? ? Sheets(1).type<Enter> また、同じように下記のように記述すると -4167 が返りませんか? ? xlWorksheet<Enter> -4167 VBEのメニューから[ツール]-->[参照設定]で「参照不可」になっている ライブラリーは、ありませんか? ありましたら、設定をやり直してください。 SRも確認してください。

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

質問者からのお礼

原因がわかりました。 いろいろテストしてみたところ元のファイルがワークシートだけで構成されていればうまく動くのですが、ダイアローグシートが入っているとそこでエラーになるようです。 どう書き換えればいいのでしょうか?お手数をおかけしますがよろしくお願いします。

質問者からの補足

ありがとうございます。 さきほどのエラーは自宅のエクセル2000での結果です。 ワ-クシート以外のシートはコピー不要です。 イミディエイトウィンドウに下記をコピー&ペーストしエンターキーをおしたら「コンパイルエラー 修正候補 式」と出ました。 「参照不可」になっているライブラリーは、ありませんでした。 よろしくおねがいします。

  • 回答No.4
  • ja7awu
  • ベストアンサー率62% (292/464)

そうですか。Excel97 では、確認しませんでした。 それでは、お聞きしますが、先程も書きましたが、 > グラフシートやダイアローグシートが入っています というこの「グラフシートやダイアローグシート」は、新しい ブックにコピーするのですか?しないのですか?

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

  • 回答No.3
  • ja7awu
  • ベストアンサー率62% (292/464)

新規で作ってみましたのでテストしてみてください。 ただ、質問内容に書いてある、下記のことですが > (AAA.xls にはワークシート以外にグラフシートやダイアローグシートが > 入っています。) これは、入っているから、どうするということを書かないと、どうすれば いいのか分かりません。 取り敢えず、ワークシート以外は、そのままコピーするようにしました ので、不要の際は、修正してください。 Else の3行を削除すればいいでしょう。たぶん。 Sub test() Dim NewObj As Workbook Dim Sh As Integer Dim Shn As String Dim Shc As Integer Dim N As Integer Set NewObj = Workbooks.Add Application.DisplayAlerts = False For Sh = 1 To ThisWorkbook.Sheets.Count   ThisWorkbook.Activate   Shn = Sheets(Sh).Name   If Sheets(Sh).Type = xlWorksheet Then     If Sheets(Sh).Range("A1").Value = True Then       Shc = Shc + 1       Sheets(Sh).Cells.Copy       If Shc > NewObj.Sheets.Count Then         NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)       End If       NewObj.Sheets(Shc).Activate       Selection.PasteSpecial Paste:=xlValues       Selection.PasteSpecial Paste:=xlFormats       For N = 1 To NewObj.Sheets.Count         If NewObj.Sheets(N).Name = Shn Then           NewObj.Sheets(N).Delete           Exit For         End If       Next N       ActiveSheet.Name = Shn       ActiveSheet.Range("A1").Select     End If   Else     Shc = Shc + 1     NewObj.Sheets.Add after:=Sheets(NewObj.Sheets.Count)     ThisWorkbook.Sheets(Sh).Copy Before:=NewObj.Sheets(Shc)   End If Next NewObj.Worksheets(1).Select NewObj.SaveAs "C:\bbb.xls" NewObj.Close Application.DisplayAlerts = True Set NewObj = Nothing End Sub  

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

質問者からのお礼

ありがとうございました。あたらしいファイルBook1が作成され、シートもコピーされましたが。 実行時エラー438「オブジェクトはこのプロパティまたはメソッドをサポートしていません。」と出て止まってしまいます。 「デバックします」を選択すると、   If Sheets(Sh).Type = xlWorksheet Then の部分がひっかかっているようでした。 どうすればいいですか?

  • 回答No.2
  • ja7awu
  • ベストアンサー率62% (292/464)

横レス失礼します。 > ためしたところエラーになってしまいました。 No.1のコードですが、ちょっと気付いたことですが、多分ここではないでしょうか。 Application.SheetsNewWorkbook = 1    ↓ Application.SheetsInNewWorkbook = 1 あと、A1に入れる TRUE は、文字列は、少ないと思いますので、どちらでも いいように ↓のようにしたら如何でしょうか? if Thisworkbook.Sheets(intSheetCnt).Range("A1").Value = "TRUE" Then    ↓ If ThisWorkbook.Sheets(intSheetCnt).Range("A1").Text = "TRUE" Then 上書き確認メッセージは、多分いらないと思いますので、前後に Application.DisplayAlerts = False Application.DisplayAlerts = True を入れたら良いかと思います。

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

質問者からのお礼

有難うございます。 うごきました。ただ、 If ThisWorkbook.Sheets(intSheetCnt).Range("A1").Text = "TRUE" Then が、エラーになったので If ThisWorkbook.Sheets(intSheetCnt).Range("A1") = True Then に変えてみました。以下のとおりです。(A1に入るtrueは文字列ではなく関数の答えです。) 今回、A1がTrueだったのは3枚のシートでしたが、結果、空白のシートをそれぞれ1枚あるファイルが3つ出来ただけでした。 ほしいのはA1がTrueのシートの書式と値を貼り付けた3つ(今回の場合は)のシートを持つ新しいファイルひとつなのですがどうすればいいのでしょうか? Sub test() Dim intSheetCnt As Integer 'これで新規ブックでのシート数を1にします Application.SheetsInNewWorkbook = 1 For intSheetCnt = 1 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(intSheetCnt).Range("A1") = True Then Workbooks.Add ThisWorkbook.Sheets(intSheetCnt).Copy ActiveWorkbook.Sheets(1) '最初にあった要らないシートを削除 Application.DisplayAlerts = False ActiveWorkbook.Sheets(1).Delete Application.DisplayAlerts = True ' '保存するファイル名はCドライブ直下でシート名 ここはお好みで ' ActiveWorkbook.SaveAs "C:\" & ThisWorkbook.Sheets(intSheetCnt).Name & ".xls" ' ' ActiveWorkbook.Close End If Next End Sub

  • 回答No.1

※TRUEは、文字でTRUEとします。 Dim intSheetCnt as Integer 'これで新規ブックでのシート数を1にします Application.SheetsNewWorkbook = 1 For intSheetCnt = 1 To Thisworkbook.Sheets.Count  if Thisworkbook.Sheets(intSheetCnt).Range("A1").Value = "TRUE" Then   Workbooks.Add   Thisworkbook.Sheets(intSheetCnt).Copy Activeworkbook.Sheets(1)   '最初にあった要らないシートを削除   Activeworkbook.Sheets(1).Delete   '保存するファイル名はCドライブ直下でシート名 ここはお好みで   Activeworkbook.SaveAs "C:\" & Thisworkbook.Sheets(intSheetCnt).Name & ".xls"   Activeworkbook.Close  EndIf Next

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

質問者からのお礼

さっそくありがとうございます。 ためしたところエラーになってしまいました。

関連するQ&A

  • EXCEL VBA

    1月から3月までの12シートからなる複数のファイルがあります。 そのファイルを上書き保存したときに書式と値だけをコピーした「ファイル名+シート名」で別ファイルに保存をかけたいのです。 (例) 営業課月次.xlsの4月シートに入力をして、上書き保存をかけた時点で月次4月.xlsにシート名=営業課月次4月で書式と値だけ保存する。 こんな都合のよいVBAがありましたら教えていただきたいと思います。宜しくお願いします。 (VBAに関しては入門編ぐらいの知識しかありません。)

  • Excelで、大量のファイルをテキストファイルにまとめて変換する方法はありますか?

     大量のExcelファイルを自動的にすべてテキストファイルに変換する方法はありますか? aaa.xls, bbb.xls, ccc.xls, ... zzz.xls         ↓ aaa.txt, bbb.txt, ccc.txt, ... zzz.txt と行った具合にです。  対象となるExcelは複数のワークシートからなりますが、いずれも変換したいシートをアクティブにした状態で保存してあります。 (でも、そうでない場合にも、例えば各ファイルの1枚目のシートを選んでテキスト形式で保存する方法があれば、それも教えていただけるとなお助かります。)  よろしくお願いします。

  • Excel VBAで他のExcelファイルのデータ取得

    Excel初心者です。 Excel VBAで他のExcelファイルのワークシートのデータを取得するのにはどうしたらいいのでしょうか。 よろしくお願いします。

  • エクセルのVBAでプログラムを作成中です。

    エクセルのVBAでプログラムを作成中です。 下二桁が1の項目のある列があれば、その列を別ワークシートの1番目の列に引用、 下二桁が2の項目のある列があれば、その列を別ワークシートの2番目の列に引用。。というように、 別ワークシートへ引用することができればな、と思います。 ポイントは、 下二桁を認識し、その値を列数と認識するにはどうすればよいか? ex) 101023がA1セルにあり。⇒ 下二桁が23なので、別ワークシートでは23列目。 application.worksheetfunction value vlookup 。。色々コードは思いつくのですが、そもそも見当違いなのかもしれません。 ご教示ください。

  • Excel(VBA)について教えてください。

    VBAの初心者です。 宜しくお願いします ワークシートに貼り付けたトグルボタンを入力が出来ない状態にしたいのですが、よくわかりません。どなたか教えていただけないでしょうか? 私が理解している範囲は次の通りです。 1)LockedプロパティーをTrueにする。 2)コントロールの書式設定でロックする 3)ワークシートの保護をかける。 これで、トグルボタンの編集はロックできますが、入力自体がロック出来ません。 宜しくお願いいたします。

  • エクセルVBAで、元になるファイルをコピーし、ファイル名を連続した日付

    エクセルVBAで、元になるファイルをコピーし、ファイル名を連続した日付としたいのですが、 ボタン一つで、ファイル名を、2010.1.1請求書.xls~2010.1.31請求書.xlsとして、 2010.1.1請求書のシート1のA1セルに、その日付2010.1.1を入力保存し、ファイルを連続作成する コードはどのようになるのでしょうか?  VBA初心者です。ご教授お願いします。

  • VBA 新規作成したファイルを開くときにエラー

    すみません、助けてください。 Excel 2007のVBAでActiveWorkbook.SaveAsを使って 新規にExcelファイルを生成するものを作成しているのですが、 新たに作成したExcelファイルを開くときにエラー(警告)が出てしまいます。 (ファイル自体は開けるのですが。。。) ソースは以下です。 ------------------------------------------------------------ ' シート枚数を指定 Application.SheetsInNewWorkbook = 3 Workbooks.Add ' 上書き保存 Application.DisplayAlerts = False ' ファイル名を指定して保存 ActiveWorkbook.SaveAs (ThisWorkbook.Path + "\" + "新しいファイル.xls")

  • 複数のexcelファイルの置換について

    AAA.xlsというファイルの中の情報を複数のexcelファイル(A.xls、B.xls、C.xls、D.xls)でリンク付けしてあるとします。 AAA.xlsをBBB.xlsに名前を変更するとリンクが成り立たなくなってしまいます。 そこで、一括でリンクを変更する方法を教えてください。 マクロでもいいです。 =[AAA.xls]Sheet1!$A$1 これを =[BBB.xls]Sheet1!$A$1 に一括変更したいのです。 よろしくお願いします。

  • EXCELのVBAについて教えて下さい。

    VBA初心者です。 EXCEL操作は今まで何度もやっていて大体のことは分るのですが、この度、仕事の関係でマクロ、VBAを初めて使わなくてはいけなくなりました。早速はじめからつまずいています。どうか私にご教授くださればと思います。 やりたいことというのが、 (1)毎日の仕事として、まず、サーバーにあるデータを集計しcsvファイルとして保存します。 (2)そのcsvファイル(ファイル名:今日落としたファイルなら○○050620.csv)を××.xlsというファイルのワークシートにコピーします。 (3)その集計した表をピボットテーブルでさらに分りやすく分別。 (4)そのピボットテーブルからでてきた数字を××.xlsのSheet1の表のあてはまるところに数字をコピーし貼り付けていきます。 それによってグラフができます。 この操作の流れのうち(2)(3)(4)の部分をマクロニ組んでしまいたいのです。なかなかうまくいかないので良い方法を教えてください。ちなみにcsvファイルは毎日の作業なので年月部分のファイル名が毎日の日付が入ります。

  • EXCEL VBAでファイルを保存しないで閉じたい

    EXCEL VBAでファイルを保存しないで閉じたい EXCEL VBAでコードを書いています。ワーク用EXCELが必要で、新規ブックを作成しています。 新規ブックで処理をさせた後に自動でブックを閉じたいと思っています。 そこで, WB.QUIT WB.CLOSE True と書いたのですが、新規ブックは閉じずにそのまま残っている状態です。 これを保存しないまま閉じるにはどのような処理が必要でしょうか?