- ベストアンサー
Excel VBAでワークシートの保存方法とボタンの削除方法を教えてください
TaketsuruOishiの回答
- TaketsuruOishi
- ベストアンサー率43% (16/37)
>Application.Dialogs(ActiveWorkbook.SaveAs).Show Arg1:=Range("D2").Value を Application.GetSaveAsFilename (Range("D2").Value) で、どうですか?
関連するQ&A
- ワークシートをコピーしたい
下記載のサンプルマクロは「ワークシートをコピーして、追加したワークブックにコピペする」マクロなんですが、これを「ワークシートをコピーして、追加したワークシートにコピペする」にできないでしょうか? 出来るのであれば、値と書式の他に関数もそのまま貼り付けたいので御教授お願いします。 ただマクロは削除してマクロ抜きのコピペが理想です。 宜しくお願い致します。 Sub サンプル() Dim sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 ThisWorkbook.Sheets("オリジナル").Cells.Copy 'コピー Workbooks.Add 'ブック追加 Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlValues '値貼り付け Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlFormats '書式貼り付け Sheets("Sheet1").Name = "コピー" Application.CutCopyMode = False Application.SheetsInNewWorkbook = sc ActiveWorkbook.Close ThisWorkbook.Activate End Sub
- 締切済み
- Excel(エクセル)
- Excel VBAについて
Excel VBAについて教えて頂きたいのですが、 Sub test() Dim lastrow, r, i As Long Dim sh1, sh2 As String Dim ws As Worksheet lastrow = Cells(Rows.count, "D").End(xlUp).row For r = 7 To lastrow '7 For i = 1 To lastrow '4 sh1 = ActiveSheet.Cells(r, 4) ActiveSheet.Cells(r, 20) = _ Application.CountIfs(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("D:D"), Range("H3") & Range("I3")) ActiveSheet.Cells(r, 21) = _ Application.CountIfs(Sheets(sh1).Range("C:C"), Range("F3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("C:C"), Range("F3")) ActiveSheet.Cells(r, 22) = _ Application.CountIfs(Sheets(sh1).Range("E:E"), Range("K3"), Sheets(sh1).Range("K:K"), "<=3") _ / Application.CountIf(Sheets(sh1).Range("E:E"), Range("K3")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") ActiveSheet.Cells(r, 15) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") - 200 ActiveSheet.Cells(r, 18) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) Sheets(sh1).Range("A3:R3").AutoFilter Field:=4, Criteria1:=Range("H3") & Range("I3") + 200 ActiveSheet.Cells(r, 19) = Application.Subtotal(105, Sheets(sh1).Range("O:O")) For Each ws In Worksheets ws.AutoFilterMode = False Next Next Next End Sub このコードは ActiveSheetで実行すると D列の7行目から最終行までに入力されている名前のシート(名前=シートがあります) その、シートの参照先で C,D,E列がcountif関数を利用して O列がSubtotal関数を利用しています。 このコードでもやりやいことは実行できるのですが、 時間がかかりすぎてしまいます。 約20件あり約2分ほどかかります。パソコンによっては倍ほど時間がかかるかもです。 そこでなのですが、 もっと処理のスピードを上げたいのですが、 可能でしょうか? 可能ならそのやり方をご教示ください。 よろしくお願い致します。
- ベストアンサー
- Visual Basic
- エクセルVBAについての質問です。
エクセルVBAについての質問です。 動作環境は OS:WINDOWS XP エクセル2003 です。 今、Book1.xlsというエクセルファイルがあります。 このファイルの中に、【sheet1】,【sheet2】,【sheet3】の3つのシートが存在しています。 【sheet1】および【sheet2】には、A列=ユニーク番号、B列=データ1、C列=データ2・・・・n列=データnの値が約1500行(各行で、データの値は異なります。)入っています。 この【sheet1】と【sheet2】のデータの内容を照合して【sheet3】にその結果を反映(TRUEまたはFALSE)します。 仮に【sheet3】のあるセル(仮にD3)の値がTRUEとなったら、【sheet1】のセル(D3)の値を【sheet3】のセル(D3)に代入する。 逆に【sheet3】のあるセルの値がFALSEとなったら、そのセルはFLASEのままにする。プログラムは以下の様にしたのですが、全てを処理するまでに相当時間がかかっています。 VBAのプログラムは今回初めて書いたので、プログラムが悪いのか、プログラムの思想が悪いのかがわかりません。 どなたかご教授していただけませんか?多分、コードの書き方もキレイではないと思います(悲) Private Sub データ照合ボタン_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Long Dim area As Range Dim A As Variant Dim WrkRange As String '----シート(1)とシート(2)の各セルの値を比較---- With Sheets("sheet1") WrkRow = .Cells(Rows.Count, 3).End(xlUp).Row End With Sheets("sheet3").Select For i = 12 To WrkRow WrkRange = Range("C" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" WrkRange = Range("D" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" '・ '・ '・ Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("C" & i).Select Selection.Copy Range("C" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("C" & i) = True Then Sheets("sheet1").Select Range("C" & i).Copy Sheets("sheet3").Select Range("C" & i).Select ActiveSheet.Paste Else: End If Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("D" & i).Select Selection.Copy Range("D" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("D" & i) = True Then Sheets("sheet1").Select Range("D" & i).Copy Sheets("sheet3").Select Range("D" & i).Select ActiveSheet.Paste Else: End If Next i '・ '・ '・ End Sub
- ベストアンサー
- Visual Basic
- Excel 2007 <VBAでグラフの操作>
Excel 2007 <VBAでグラフの操作> 現在すでにあるグラフを修正しています。 下記マクロでは「各グラフに系列が2つあり、その1つ目を削除して残る1つのデータ範囲(X軸の値)を再設定する」という内容です。 下記マクロではFor構文冒頭のSet~の行で、 「実行時エラー '1004': 'Cells'メソッドは失敗しました:'_Global'オブジェクト」 とのエラーが出ます。 このエラーについて検索してみたのですが、これといったものが見つからなかったので、このマクロでおかしなところがあれば直接指摘していただけないでしょうか。 よろしくお願いします。 Private Sub Test_Arrange() Dim MyRng As Range Dim R As Integer Dim n As Integer Dim i As Integer n = 10 R = Sheets("Sheet1").Range("A1").End(xlDown).Row For i = 1 To n Set MyRng = Sheets("Sheet1").Range(Cells(2, 2 * n + 3), Cells(R, 2 * n + 3)) Charts(i).SeriesCollection(1).Delete Charts(i).SeriesCollection(1).XValues = MyRng Next i End Sub
- ベストアンサー
- その他MS Office製品
- エクセルVBAマクロの質問です。
マクロ初心者です。行き詰まってます。 sheet1には300件程度のデータがあります。 このデータの3列目の値を、VLOOKUPでsheet3のA1:B30範囲から参照します。そこで取得した回数分、sheet1の各行のデータをsheet2にコピーしたいんです。 そこで、コード文を作ってみましたが、マクロがうまく動きません。 すみませんが、お知恵を貸していただけないでしょうか? Dim Z as Long Dim L As Long Dim P As Long Dim Kensaku As String Dim M4 As Range Dim PRow As Long Dim i As Long Set M4 =Sheets(“sheet3”).Range(“A1:B30“) L = Sheets(“sheet1”).Range(“A1”).End(xlup).Row For Z = 1 to L-1 Kensaku = Sheets(“sheet1”).Cells(Z+1,3).Value P=Worksheetfunction.Vlookup(Kensaku,M4,2,False) For i = 1 to P Prow=Sheets(“sheet2”).Range("A1").End(xlDown).Row Sheets(“sheet1”).Rows(Z+1).Copy Sheets(“sheet2”).Rows(Prow) Nexti Next Z
- 締切済み
- Visual Basic
- EXCEL VBAの配列でわかりません。
こんなコードがあるのですが、最後の他のシート(作業中シート)に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ~??わからな~い??おしえてくださーい!! Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル VBA シート保存ボタン
Sheet上にボタンを作成 ボタンを押すと保存するようにしています! 以前ここでSheet2枚をコピー出来るような 記述教えてもらったのですが・・ 1枚ならどう変化して良いか・・ 記述を書きましたが 何処が違うか教えて下さい! Private Sub CommandButton1_Click() Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "ko" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("A1").Value FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1)).Copy Set NewWkbook = ActiveWorkbook For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count NewWkbook.Sheets(1).Shapes(wIx).Delete Next NewWkbook.Sheets(1).Name = StName1 ' FileName = "D:\保存\計画\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub 教えて下さい!
- ベストアンサー
- オフィス系ソフト
- 既存のエクセルマクロに命令文を追加
既存のマクロに別の命令文を追加する場合について質問です。 選択した範囲のオブジェクトを削除するマクロがあります。 下の命令文に 「シート2でも同じことをする(ただし選択範囲はC30からG33)」 を追加する場合には、どのように書けばいいのでしょうか? Sheets("シート1").Select Range("A65:E365").Select Dim shp As Shape Dim rng_shp As Range 'セルが選択されていないときは終了 If TypeName(Selection) <> "Range" Then Exit Sub 'アクティブシートのすべての図形にループ処理 For Each shp In ActiveSheet.Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば図形を削除 If Not Intersect(rng_shp, Selection) Is Nothing Then shp.Delete End If Next Sheets("シート0").Select Range("A1").Select 同じものを上記命令文の下にコピーして選択シートと範囲を直すだけだと、 Dim shp As ShapeとDim rng_shp As Rangeがエラーになります。 どなたかご教示お願いします。
- 締切済み
- その他(ビジネス・キャリア)
- エクセルで型番ごとにワークシートをマクロで作る方法
昨日に質問させて頂いたものですが、下記のマクロを教えて頂いたのですが 新しく生成された型番のワークシートが抜けていたり、最後まで型番が生成されない状態です。 なにか間違っていたら直して頂ける方お願いします。 Sub macro4() Dim h As Range Dim w As Worksheet Dim i As Long, e As Long Application.ScreenUpdating = False Application.CutCopyMode = False ’準備 Set w = ActiveSheet w.Range("4:4").Insert shift:=xlShiftDown e = Range("B65536").End(xlUp).Offset(1).Row Range("B4").Select ’複写 Do ActiveSheet.Copy after:=ActiveSheet Selection.EntireRow.Delete shift:=xlShiftUp Loop Until ActiveCell.Offset(1) = "" ’片付け For i = ActiveSheet.Index To w.Index + 1 Step -1 With Worksheets(i) .Range(.Range("B4").Offset(1), .Cells(e, "B")).EntireRow.Delete shift:=xlShiftUp End With Next i w.Rows(4).Delete Application.ScreenUpdating = True End Sub http://okwave.jp/qa/q7081084.html
- ベストアンサー
- その他MS Office製品
- エクセルVBAでファイル保存失敗の原因?
エクセル2010です。 Sheets("DATA")にある822件のデータを、D列のデータ(担当者名)をキーにフィルター抽出し、雛形のシートにコピーして、そのシートを別ファイルとして名前をつけて、指定したフォルダーのサブフォルダに保存するマクロです。(サブフォルダ名はデータのG列にある文字列です。) キーとなる担当の数は223です。 以下のコードで一応作動するのですが、同じデータを使っても2回に一回くらいの割合で保存ができず、 wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx" のところで止まってしまいます。 エラーは 「実行時エラー1004 SaveAsメソッドは失敗しました。Workbookオブジェクト」 というものです。このとき、画面上ではあたらしいファイルが出来あがっております。しかしその出来てるファイルを手動で保存しようと思っても、 「○○○(ファイル名)は保存中にエラーが検出されました。いくつかの機能を削除または修復することによりファイルを保存できる場合があります」 とでてしまいます。 まだテスト段階で、同一のデータでテストしているのですが、止まるデータは30件目であったり、140件目であったり、まちまちです。2回に1回くらいは最後まで動き、すべて正しく作成され保存できているので、データの問題ではないと思います。 ほかにどんな問題が考えられるのでしょうか?とても困っています。 Sub TEST20151114() Dim SaveDir As String, bcde As String, sbfdr As String Dim wb(1) As Workbook Dim i As Long, x As Long Dim myRng As Range, myC As Range Dim t t = Time Set wb(0) = ThisWorkbook Set myRng = wb(0).Sheets("担当別").Range("B2:B224") Application.ScreenUpdating = False For Each myC In myRng wb(0).Sheets("回答雛型").Copy After:=wb(0).Sheets("回答雛型") wb(0).Sheets("回答雛型 (2)").Name = "回答シート" With wb(0).Sheets("DATA") .AutoFilterMode = False .Range("A1:J1").AutoFilter .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value 'D列 .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy Sheets("回答シート").Range("A2") .ShowAllData x = wb(0).Sheets("回答シート").Cells(Rows.Count, "A").End(xlUp).Row .Range("A823:J827").Copy wb(0).Sheets("回答シート").Range("A" & x + 1) '予備5行追加 End With With wb(0).Sheets("回答シート") .Rows(x + 6 & ":" & .Rows.Count).Delete Shift:=xlUp Application.Goto Reference:=.Range("A1"), Scroll:=True bcde = CStr(Trim(.Range("E2").Value)) sbfdr = Trim(.Range("G2").Value) 'サブフォルダ名 .Move End With Set wb(1) = ActiveWorkbook SaveDir = wb(0).Path & "\20151114\" & sbfdr '保存先 If Dir(SaveDir, vbDirectory) = "" Then MkDir SaveDir '無ければサブフォルダ作成 End If DoEvents wb(1).SaveAs Filename:=SaveDir & "\" & bcde & "_" & Trim(myC.Value) & ".xlsx" wb(1).Close (False) myC.Offset(, 1).Value = x - 1 i = i + 1 Application.StatusBar = i & "/" & myC.Value Set wb(1) = Nothing Next myC Set wb(0) = Nothing Application.ScreenUpdating = True MsgBox i & "個のファイルを作成しました。" & vbCrLf & Format(Time - t, "hh:mm:ss") Application.StatusBar = "" End Sub
- ベストアンサー
- Excel(エクセル)
お礼
さっそくのご回答ありがとうございます。 ただ、実行しても、ファイルの種類がすべてのファイルになってしまい、一度保存ボタンを押して、その後再度.xlsで保存しなおすという形で保存しなおさなければなりません。 マクロを実行したら、最初から(.xls)ファイルで保存出来るような形で出来ないでしょうか?