VBAでExcel Workbookを自動作成する方法
- 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
- grace_jns
- お礼率100% (1/1)
- その他MS Office製品
- 回答数1
- ありがとう数2
- みんなの回答 (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
関連する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
- ベストアンサー
- Visual Basic
- エクセル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
- ベストアンサー
- Visual Basic
- エクセル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
- ベストアンサー
- その他MS Office製品
- 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
- ベストアンサー
- その他MS Office製品
- エクセル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
- ベストアンサー
- Excel(エクセル)
- 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
- ベストアンサー
- Visual Basic
- エクセル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が持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel(エクセル)
- エクセル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
- ベストアンサー
- Excel(エクセル)
お礼
ご記入頂いたソースで実行、無事期待通りの結果が出力されました。 後学の為、頂いたソースで検索して処理も理解出来ました。 なるほど!と目からウロコがこぼれた気分です。 本当にありがとうございました。