VBAでExcel Workbookを自動作成する方法

このQ&Aのポイント
  • Excel VBAを利用してWorkbookを自動作成する方法について質問があります。
  • 既存のWorkbookを元に新しいWorkbookを作成し、データを入力して保存する際に、保存後のWorkbookを開いた時の挙動を指定する方法を教えてください。
  • 具体的なサンプルコードを添付しましたので、ご確認ください。
回答を見る
  • ベストアンサー

VBAについて質問です。

VBAについて質問です。 現在、ExcelにてWorkbookを自動で作成するモジュールを作成しています。 モジュールを記載しているWorkbookを [wbSorce] 自動で作成されるWorkbookを [wbNew] とします。 [wbSorce] でモジュールを実行すると、 [wbNew] を新規に作成し、 データを入力して保存するのですが、保存する際に [wbNew] のイベントハンドラ [Workbook_Open] に 保存された [wbNew] を開いた時の挙動を記載するには どうすればよいでしょうか? サンプルは下記になります。 ****[wbSorce]のモジュール**** Sub wbNew_Sakusei()   Dim wb As Workbook   Dim wb2 As Workbook   Dim i As Integer   Set wb = ThisWorkbook   Set wb2 = Workbooks.Add   For i = 1 To 5     wb2.Sheets(1).Cells(1, i) = wb.Sheets(1).Cells(1, i)   Next   wb2.SaveAs Filename:="wbNew" End Sub ****[wbNew]に記述したいモジュール**** Private Sub Workbook_Open()   ActiveWindow.ScrollRow = 1   MsgBox "Workbook_Openイベントが発生しました。" End Sub

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

  • ベストアンサー
回答No.1

"C:\temp\Macro.txt"に、****[wbNew]に記述したいモジュール****の内容を記述しておいてください。 Sub wbNew_Sakusei() Dim wb As Workbook Dim wb2 As Workbook Dim i As Integer Set wb = ThisWorkbook Set wb2 = Workbooks.Add For i = 1 To 5 wb2.Sheets(1).Cells(1, i) = wb.Sheets(1).Cells(1, i) Next With wb2.VBProject .VBComponents("ThisWorkbook").CodeModule.AddFromFile "C:\temp\Macro.txt" End With wb2.SaveAs Filename:="wbNew" End Sub

grace_jns
質問者

お礼

ご記入頂いたソースで実行、無事期待通りの結果が出力されました。 後学の為、頂いたソースで検索して処理も理解出来ました。 なるほど!と目からウロコがこぼれた気分です。 本当にありがとうございました。

関連するQ&A

  • VBA VLOOKUP 別のファイルを参照

    VBA VLOOKUP 別のファイルを参照 いつもこちらでお世話になっている者です。 VBAの勉強をしております。 別のファイルからVLOOKUPで値を参照したいのですが、 範囲を指定してみましたが、 「worksheetFunctionクラスのVlookupプロパティを参照できません」 とのメッセージが出てしまいます。 なお、値は空白になる行もありますので、 if関数で回避してみましたがうまくいきません。 いろいろ試しましたが、何度やってもうまくいかないので こちらに質問させていただきました。 お詳しい方、ご伝授いただければ助かります。 よろしくお願い致します。 環境はExcel2007です。 Sub sample() Dim 範囲 As Range Dim wb As Workbook, wb2 As Workbook Dim r As Integer,intRow As Integer Workbooks.Open Filename:="***.xlsm" Set wb = ThisWorkbook Set wb2 = ActiveWorkbook Set 範囲 = wb2.Sheets("PvtSht2").Range("Database3") r = wb.Sheets("sheet1").Range("A28:N28").End(xlToRight).ColumnintRow = 3 With wb.Sheets("sheet1") Do Until .Cells(intRow, 1).Value = "" .Cells(intRow, (r + 1)) = Application.WorksheetFunction.If((Application.WorksheetFunction.VLookup(Cells(intRow, 1), 範囲, 2, False)) = 0, "", Application.WorksheetFunction.VLookup(Cells(intRow, 1), 範囲, 2, False)) intRow = intRow + 1 Loop End With End sub

  • エクセルVBAで作成した別ブックにVBAを記述したい

    VBAで別ファイルの作成は下記で出来ているのですが、出来上がったファイルにVBAを記述する方法がわかりません。 具体的には一番下のSub TEST()を新しいブックの標準モジュールに記述したいのと、sheet1に Private Sub Worksheet_Change(ByVal Target As Range) MsgBox "ChangeTEST" End Sub を入れたいです。 また Private Sub Workbook_Open() MsgBox "OpenTEST" End Sub も入れたいのです。 どうぞご教示ください。 Sub 複製() Dim wb As Workbook, sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Set wb = Workbooks.Add Application.SheetsInNewWorkbook = sc wb.Sheets("Sheet1").Select ThisWorkbook.Sheets("Sheet1").Cells.Copy wb.Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Buttons.Add(123, 195, 68.25, 15).Select Selection.OnAction = "TEST" Selection.Characters.Text = "TEST" ActiveWorkbook.Close ThisWorkbook.Activate Sheets("Sheet1").Select End Sub Sub TEST() MsgBox "TEST!!" End Sub よろしくお願いします。

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • エクセルVBAでBOOKを開く際の処理

    エクセルVBAでBOOKを開く際の処理 エクセル2000です。 VBAで特定のフォルダー内のBOOKを開き、1枚目のシートSheets(1)のデータを読み込んで別BOOK(マクロを記載したBOOK)にコピペしたら保存せず閉じるコードを下記のように書きました。(かなり簡略化しましたが) これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても1枚目のシートのデータを読み込み後、閉じられてしまいます。 BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか? Sub TEST01()   Dim mb As Workbook, wb As Workbook   Dim myfd As String, fnme As String, ans As Byte, i As Long      ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")   If ans = vbNo Then     MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"     Exit Sub   End If      Set mb = ThisWorkbook   myfd = mb.Path   fnme = Dir(myfd & "\*.xls")      Do Until fnme = Empty     If fnme <> mb.Name Then       Set wb = Workbooks.Open(myfd & "\" & fnme)       i = i + 1       mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")       wb.Close (False) '保存せずに閉じる     End If     fnme = Dir   Loop        Set mb = Nothing   Set wb = Nothing   MsgBox i End Sub

  • VBAで Set wb = Sheets(1).Copyができないわけ?

    つい先ほどの質問 4150169 は掲示したコードが抜けておりましたので無視して、こちらにご回答ください。 ほんと抜けた話です。すみません。 以下のマクロtest01はエラーになります。 Sub test01() Dim wb As Workbook Set wb = Sheets(1).Copy 'エラー「オブジェクトが必要です」 End Sub もちろん Dim wb As Workbook Sheets(1).Copy Set wb = ActiveWorkbook と修正すればエラーにならないことは存じていますが、ふと疑問がわきました。 Sheets(1).Copyの段階であたらしいWorkbookが誕生していますよね。 ならば、そのWorkbookはオブジェクトではないのでしょうか? Workbooks.Add で誕生したWorkbookは Set wb = Workbooks.Add と変数wbにSetできるのに Set wb = Sheets(1).Copy ができないのが不思議です。 Set wb = ActiveWorkbook としないでもSheets(1).CopyをwbにSetする書き方はないのでしょうか?

  • Excel 2007 マクロ 別ブックのシートをコピーする方法

    Excel 2007 マクロ 別ブックのシートをコピーする方法 別ブックのシートをコピーして アクティブなブックのシートにコピーしたいと思います。 下記マクロを作成しました。 貼り付ける際に、クリップボードに保存するかどうか 聞かれるメッセージが表示されてうまくいきません。 またもっとシンプルな書き方があればアドバイスお願いします。 Sub 取り込み() Dim wb As Workbook Set wb = Workbooks.Open("\") Sheets("Sheet1").Select Cells.Select Selection.Copy ThisWorkbook.Activate ThisWorkbook.Sheets("特定").Select ActiveSheet.Cells(1, 1).Select ActiveSheet.Paste wb.Close End Sub

  • エクセルVBAで読み取りパスワード回避

    エクセル2010です。 以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。 しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。 読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB" などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。 そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。 (BOOK作成者にあとからパスワードを聞くため) しかし、残念ながらどのように書けばいいのか思いつきません。 ご指導いただければ幸いです。 Sub TEST001()   Dim wb(1) As Workbook   Dim ws(1) As Worksheet   Dim myFdr As String, fn As String   Dim i As Long   With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定     If .Show = True Then        myFdr = .SelectedItems(1)     Else       Exit Sub     End If   End With   Application.ScreenUpdating = False '画面更新を一時停止   Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。   Set ws(0) = wb(0).Sheets(1) 'wb(0)の1枚目のシートをws(0)とする。   fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索   Do Until fn = Empty '全て検索     Application.EnableEvents = False     Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。     Set ws(1) = wb(1).Worksheets(1)     i = i + 1     ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記     ws(0).Cells(i, "B").Value = wb(1).Name     ws(0).Cells(i, "C").Value = ws(1).Name     wb(1).Close (False) '保存せず閉じる     Application.EnableEvents = True     fn = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   Application.ScreenUpdating = True '画面更新停止を解除   MsgBox i & "個取得" End Sub

  • VBAを使った九九、及び合計、平均の表の作り方

    Visual Basic初心者です。 Excel 2003を使って、九九表を表示させるプロジェクトを作りたいのですが、どうしても途中で詰まってしまい、九九だけどころか、合計と平均すら表示させることができない状態です。 私の途中まで組んだタグは以下の通りです。どなたかよろしくお願いします。 Private Sub CommandButton1_Click() Call Kuku End Sub Option Explicit Dim Sum(20) As Double Sub Kuku() Dim i As Double, j As Double, num As Integer num = InputBox("numの値を入力しなさい") Sheets("Date").Cells.Clear For i = 1 To num Sheets("Date").Cells(1, i + 1) = i Sheets("Date").Cells(1 + i, 1) = i Sum(i) = 0# For j = 1 To num Sheets("Date").Cells(i + 1, j + 1).Value = Sum(i) Sum(i) = i * j Next j Next i Call Heikin Call Hyoudai MsgBox ("処理が終了しました") Sheets("Date").Select End Sub Sub Heikin() Dim i As Double, num As Integer, n As Integer For i = 9 To num Sheets("Date").Cells(i + 1, n + 2).Value = Sum(i) Sheets("Date").Cells(i + 2, n + 1).Value = Sum(i) Next i End Sub Sub Hyoudai() Sheets("Date").Cells(1, 1) = "九九" Sheets("Date").Cells(1, 11) = "合計" Sheets("Date").Cells(1, 12) = "平均" End Sub

  • エクセルVBAでファイル作成

    エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記()   Dim myPth As String, fname As String   Dim myRng As Range, myC As Range   Dim i As Long, x As Long   Dim wb(2) As Workbook   Dim ws As Worksheet   Dim t As Single   t = Timer   Set wb(0) = ThisWorkbook   myPth = wb(0).Path   With wb(0).Sheets("Key")     Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData   End With      For Each myC In myRng     Application.EnableEvents = False     Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm")     Set ws = wb(1).Sheets("List")        With wb(0).Sheets("DATA")       .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value       .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9")       .ShowAllData     End With     With ws       x = .Cells(Rows.Count, "A").End(xlUp).Row       myC.Offset(, 2).Value = x '行数確認       .Range("A9").Value = 1       If x > 9 Then         .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番       End If     End With     wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"     wb(1).Close (False)     Application.EnableEvents = True     i = i + 1   Next   MsgBox i & "件を完了" _   & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。

  • エクセルVBAでBOOKに読み取りパスワード設定

    エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01()   Dim myfdr As String, fname As String   Dim mb As Workbook, wb As Workbook   Dim n As Long   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定      If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。"       Exit Sub     End If   End With   Set mb = ThisWorkbook 'このコピー先ブックをmbとする。   fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索   n = 2   Do Until fname = Empty '全て検索     Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。     With mb.Sheets("Sheet1") '転記       .Cells(n, "B").Value = wb.FullName       .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value     End With     n = n + 1 'カウント     Application.DisplayAlerts = False     wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"     wb.Close     Application.DisplayAlerts = True     fname = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   MsgBox n - 2 & "件処理しましました。" End Sub

専門家に質問してみよう