[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ＶＢＡ オートフィルタで抽出したデータとデータの間に行挿入』（usamiyu）
いつも大変お世話になっております。 ＶＢＡで標記のことを行いたいのですが、教えてください。
(概 要） シートの複数列を非表示にし、該当列に色をつけ、表示されている列の一番左端でオートフィルタをかけます。 ここまでは下記のコードでできました。 その後、オートフィルタで抽出したデータとデータの間に各データを合計するための行を作りたいのですが、 その方法を教えてください。
(レイアウト） S列 1 事項名▼ 2 一般 . 一般 . 一般 6 一般 (ここに合計行を挿入） 7 特別 . 特別 (ここに合計行を挿入） 9 緊急 10 緊急 (ここに合計行を挿入）
(コード）
途中まで書いたコードは次のとおりです。だめな点もご指摘ください。
Sub tyousa ()
Dim myR As Range
Dim myR2 As Range
With Sheets(3)
With .Range("A:R,T:T,V:V,Y:Y,AG:AQ") '各列を範囲指定
.EntireColumn.Hidden = True '指定した列を非表示に
End With
.Columns("AB:AB").Interior.ColorIndex = 35 '指定列の色を薄緑に
.Columns("AE:AE").Interior.ColorIndex = 34 '指定列の色を薄いブルーに
Set myR = .Range("S1", .Range("S" & .Rows.Count).End(xlUp)).Resize(, 13)
.AutoFilterMode = False
myR.AutoFilter Field:=1, Criteria1:="特別"
'この後が？？
お手数ですが、どうかよろしくお願いいたします。
目的はオートフィルターではなく、Ｓ列の文字列毎に小計行を挿入するということなのかな？ それとも、オートフィルターに意味があるのかな？ Ｓ列の文字列は並び替えで同じものが連続しているのかな？それともばらばら？
ちょっと、元のシートのイメージとできあがりのイメージがつかめないところがあるんだけど もしＳ列の文字列が連続しているなら、"小計"機能でできそうだけど、そういう意図ではないのかな？
(ぶらっと)
(ぶらっと)さん、ありがとうございます。 恥ずかしながら、小計？集計？機能を知らなかったです。エクセルの機能、何も知らないんだなぁと痛感してます。
>目的はオートフィルターではなく、Ｓ列の文字列毎に小計行を挿入するということなのかな？ はい。そうです。 >Ｓ列の文字列は並び替えで同じものが連続しているのかな？ 連続しています。
業務に使用しているシステムからＣＳＶファイルで、データを吐き出して、ＸＬ形式にして保存 しているので、それを、Ｓ列の文字列ごとに小計行を挿入して、報告用の資料を作成するという意図です。
頻繁に同じような作業をしているため、ＶＢＡの勉強も兼ね、このコードを完成したいのですが、 その場合、集計機能をコードにすればいいということですか？
能力不足でできていないのですが、本当はもう一歩進めて、ＣＳＶファイルの状態からＸＬ形式で保存する 段階からＶＢＡでやれればいいなとも考えています。
質問下手で恐縮です。アドヴァイスいただけますか？
(usamiyu)
リストの任意の場所（S1とか）を選択した上で2003ならデータ->集計、 2007以降ならデータメニューの右のほうにある小計ボタンをおして、集計のためのキーの列や集計すべき数値列を指定する。
http://www.eurus.dti.ne.jp/yoneyama/Excel/syukei.html
あたりが、わかりやすいと思う。
同じような処理でアウトライン機能もあるね。自分自身はあまり使わないけど【学校】のライブラリの
https://www.excel.studio-kazu.jp/lib/e5a/e5a.html
あたりにわかりやすく操作方法の説明があるよ。
追記）もちろん、操作をマクロ記録してコードを生成することができるよ。
追記２）
>ＣＳＶファイルの状態からＸＬ形式で保存する段階からＶＢＡでやれればいいなとも考えています。
処理としては、【開いてから】行う方が（もちろん）簡単なので、ＣＳＶファイルをエクセルから開く操作もマクロ記録できるね。
(ぶらっと)
おはようございます。早朝からヒントをありがとうございます。 とにかく、いちから仕切りなおして、マクロ記録から始めます。
(usamiyu)
アドヴァイスどおり、集計機能についてのマクロの記録や、以前教えていただいたファイルパスの指定方法を総動員して作成してみました。コードは下記のとおりです。 あと一歩なんですが、ブックを保存するときに実行時エラー１００４ほかの開いているブック又はアドインと同じ名前で保存できません というエラーになります。
やりたいことは、ＣＳＶファイルと同じブック名で、ＸＬ形式にして、同じフォルダに保存したいのですが、どのようにしたらよいか教えていただけますか？
それと、集計機能をコード化するときにselectionを使ってしまったのですが、使わないとすれば、どのように記述したらよいでしょうか？ Activesheetとか使ってみたのですが、実行時エラーになってしまったので、とりあえず、selectionのままにしています。
Sub CSV_Open_Subtotal()
Dim FilePath As Variant
'CSVファイルを選択
FilePath = Application.GetOpenFilename("csvファイル,*.csv")
If FilePath = False Then
Exit Sub
End If
'ファイルを開く
Workbooks.Open Filename:=FilePath
'ここから加工する
With Sheets(1)
With .Range("A:R,T:T,V:V,Y:Y,AG:AQ") '各列を範囲指定
.EntireColumn.Hidden = True '指定した列を非表示に
End With
'集計機能
Selection.Subtotal GroupBy:=19, Function:=xlSum, TotalList:=Array(28, 31, _
43), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.UsedRange.Style = "Comma [0]" 'カンマ付与
.Columns("AB:AB").Interior.ColorIndex = 35 '指定列の色を薄緑に
.Columns("AE:AE").Interior.ColorIndex = 34 '指定列の色を薄いブルーに
With .Range("S:S,U:U,W:X,Z:Z,AA:AF")
.EntireColumn.AutoFit
End With
End With
'ここから保存する ↓ここで実行時エラー1004 ほかの開いているブック又はアドインと同じ名前で保存できません
ActiveWorkbook.SaveAs _
Filename:=ThisWorkbook.Path & "\" & ThisWorkbook.Name & "更新.xls", _
FileFormat:=xlNormal, _
CreateBackup:=False
ActiveWorkbook.Close
End Sub
(usamiyu)
次のように変更してみました。 それで、ＣＳＶファイルと同じブック名で、ＸＬ形式にして、同じフォルダに保存できました。
なので、疑問点は次の1点だけ残っています。お手数をおかけします。ご教授、ご指摘いただければ幸いです。
集計機能をコード化するときにselectionを使ってしまったのですが、使わないとすれば、どのように記述したらよいでしょうか？
Sub CSV_Open_Subtotal()
Dim wb As Workbook
Dim myPath As String
Dim sep As String
Dim FilePath As Variant
sep = Application.PathSeparator '\
'CSVファイルを選択
FilePath = Application.GetOpenFilename("csvファイル,*.csv")
If FilePath = False Then
Exit Sub
End If
'ファイルを開く
Set wb = Workbooks.Open(FilePath)
'ここから加工する
With Sheets(1)
With .Range("A:R,T:T,V:V,Y:Y,AG:AQ") '各列を範囲指定
.EntireColumn.Hidden = True '指定した列を非表示に
End With
'集計機能 ↓ここのselectionが気になっています。
Selection.Subtotal GroupBy:=19, Function:=xlSum, TotalList:=Array(28, 31, _
43), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.UsedRange.Style = "Comma [0]" 'カンマ付与
.Columns("AB:AB").Interior.ColorIndex = 35 '指定列の色を薄緑に
.Columns("AE:AE").Interior.ColorIndex = 34 '指定列の色を薄いブルーに
With .Range("S:S,U:U,W:X,Z:Z,AA:AF")
.EntireColumn.AutoFit
End With
End With
wb.Save
'ここから保存する
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & sep & "CSVファイル" & sep
wb.SaveAs myPath & wb.Name & ".xls"
wb.Close
End Sub
(usamiyu)
集計機能やオートフィルターや並び替え等々、【リスト領域】を相手にするメソッドの領域に単一セルを指定すると
ＶＢＡはそのセルのCurrentRegionとみなしてくれる。
なので、（リストの全貌はみえないけど）Selection.Subtotal は .Range("A1").SubTotal で処理ＯＫだと思う。
一度やってみてくれる？
追記）アップされたコードではＡＢ，ＡＥ列全体に色をつけてるね。そういう意図ならいいけど たとえば Dim z As Long といった変数を準備しておいて
z = .Range("A1").CurrentRegion.Rows.Count
.Columns("AB:AB").Resize(z).Interior.ColorIndex = 35 '指定列の色を薄緑に
.Columns("AE:AE").Resize(z).Interior.ColorIndex = 34 '指定列の色を薄いブルーに
こんなふうにしてもいいかもしれないね。
(ぶらっと)
ぶらっとさん、何度もお手間をおかけして申し訳ありません。また、ご相談してもいいですか？ 不具合発生です・・う～ん
教えていただいた箇所ではありません。
.Range("A1").SubTotal はうまくいきました。ありがとうございます。
あと、変数sepへの代入が抜けていたので、そこを訂正して、うまくいったかと思ったのですが、
デスクトップのＣＳＶファイルの保存されたデータが次のように、一つのセルにカンマで区切った文字列が入るような表示になっています。
↓ 受付番号,年度,コード,名称,種別,種別名称,収支区分,款コード,項コード,目コード,節コード,細節コード,事項コード,款名称,項名称,目名称,節名称,以下省略 20,121,022,031,001 ,"2,012 ",3 ,ああああ ,0 ,現年度予算 ,4 ,4 ,1 ,5 ,1 ,0 ,51 ,資本的支出 以下省略 , ,"325,238,000 ",0 ,0 ,0 ,0 ,0 ,0 , , ,107 ,4 ,1 ,5 ,1 ,0 ,1 ,0 ,10 ,,,,,,,,,,,,,,,,,,特別 集計,,,,,,,,,"314,317,500 ",,,"13,807,500 ",,,,,,,,,,,,"137,139 "
エクセルファイルだけれど、1セルごとにデータが入っていません。
これは、wb.SaveAs myPath & wb.Name & ".xls" の部分が間違っているのでしょうか？
※17:34一部修正 (usamiyu)
要件を読み違えているかもしれないけど。 以下のようにしたらどうｋな？
'ここから保存する
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & sep & "CSVファイル" & sep
wb.SaveAs myPath & Split(wb.Name, ".")(0) & ".xls", FileFormat:=xlNormal
wb.Close False
で、気になることが。 このコードの上に wb.Save があるね。この時点でのwb は CSVファイル。 なので、集計機能で挿入された行は、CSVファイルの機能としてはサポートできないので、通常の行になってしまう。 それでいいなら、いいんだけど・・・
あぁ、それとCSVファウルをオープンしてアクティブブックになっているからいいんだけど、 せっかく wb を規定しているんだから With wb.Sheets(1) にしておいたほうが、なんとなく、安心できるというか よりわかりやすいと思うね。
(ぶらっと)
できました！ぶらっとさんの読みどおりです！ いつも読み取りづらい私の状況を理解していただいてありがとうございます。
なるほど～wbのファイル名から拡張子だけ取り去って、xlsにし、xl形式を指定して保存するんですね。 あと、wb.Close False としているのは保存ダイアログボックスを出さないためですね。これを どうやったら出ないようにできるのかなぁと思っていました。
>で、気になることが。 >このコードの上に wb.Save があるね。 削除しました。最初に書いたコードで実行時エラー１００４が出たとき、ほかのファイルが開いて いなければいいのかと思ってとりあえずSaveしたつもりでした。
>With wb.Sheets(1) にしておいたほうが はい。そうしました。wbを宣言したのが変更後だったのでうっかりしていました。
それで、最後にひとつだけ、心残りがあるのですが、 各集計行にInterior.ColorIndex = 36として色をつけたいのですが、
各集計行を取得するにはどうしたらいいでしょうか。
何かヒントのひとつでもいただけたら・・・お願いします(^^ゞ
(usamiyu)
小計を設定したシートの左側に、各行のレベルのツリーのようなものが表示されているよね。 今回のケースでは、1,2,3。小計がレベル2,最後の総計がレベル1,各行はレベル3。
で、全部の行.レベル2の行 といったコレクションの取得ができれば便利なんだけど、それはないので、 各行のレベルを調べることになる。
Sub Sample()
Dim myRow As Range
With wb.Sheets(1)
For Each myRow In .Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then myRow.Interior.ColorIndex = 36
Next
End With
End Sub
(ぶらっと)
ぶらっとさん、いつも本当にありがとうございます。全て解決です！
上の処理を行い、Application.ScreenUpdatingの手当てを行い、完成しました。 一応、完成形をアップしてみます。
また、次の業務を効率化しながら、ＶＢＡの練習を続けます。いつもご面倒をおかけしていますが、 次回もどうぞよろしくおねがいいたします。(もう嫌だって言わないでくださいね^^;）
Sub CSV_Open_Subtotal完成版()
Dim wb As Workbook
Dim myPath As String
Dim sep As String
Dim z As Long
Dim myRow As Range
Dim FilePath As Variant
sep = Application.PathSeparator '\
'CSVファイルを選択
FilePath = Application.GetOpenFilename("csvファイル,*.csv")
If FilePath = False Then
Exit Sub
End If
Application.ScreenUpdating = False '画面描画停止
'ファイルを開く
Set wb = Workbooks.Open(FilePath)
'ここから加工する
With wb.Sheets(1)
With .Range("A:R,T:T,V:V,Y:Y,AG:AQ") '各列を範囲指定
.EntireColumn.Hidden = True '指定した列を非表示に
End With
'集計機能
.Range("A1").Subtotal GroupBy:=19, Function:=xlSum, TotalList:=Array(28, 31, _
43), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.UsedRange.Style = "Comma [0]" 'カンマ付与
z = .Range("A1").CurrentRegion.Rows.Count
.Columns("AB:AB").Resize(z).Interior.ColorIndex = 35 '指定列の色を薄緑に
.Columns("AE:AE").Resize(z).Interior.ColorIndex = 34 '指定列の色を薄いブルーに
For Each myRow In .Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then myRow.Interior.ColorIndex = 36 '各集計行をベージュに
Next
With .Range("S:S,U:U,W:X,Z:Z,AA:AF")
.EntireColumn.AutoFit '表示列の幅調整
End With
End With
'ここから保存する
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & sep & "CSVファイル" & sep 'デスクトップに
wb.SaveAs myPath & Split(wb.Name, ".")(0) & ".xls", FileFormat:=xlNormal '現在開いているブックの名前で、Xl形式にて保存
wb.Close False '保存ダイアログを出さずにブックを閉じる
Application.ScreenUpdating = True '画面描画再開
End Sub
(usamiyu)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.