[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『自動で条件抽出し別ブックへ転記』（バムセ）
※タイトル変更しました。
従業員情報のデータベース（Ｅｘｃｅｌ）があります。
ＶＢＥで「フォーム」を作成し、条件項目を入力するところを作って、
その条件を入力し検索すると、
検索した結果が別シートに作成される…
といった機能を作成することは可能でしょうか？
（ほぼＶＢＡを触ったことがないため可能性すらわかりません）
条件1：〇月〇日〜〇月〇日（例：2000年4月1日〜2020年3月31等）
条件2：従業員ＩＤ（8桁）
条件3：学歴（〇〇大学等）
どんなことを勉強すればよいか、
またコード等教えていただけますと幸いです。
＜ 使用 Excel：Office365、使用 OS：unknown ＞
直接の回答ではありません。
http://officetanaka.net/excel/vba/vbe/
（OK） 2020/10/15(木) 16:07
↓の方がよかったかな。
http://officetanaka.net/excel/vba/beginner/01.htm
（OK） 2020/10/15(木) 16:08
とりあえず、
エクセル VBA 複数条件 検索
でここの各ログ検索やネット検索してみてください。 （OK） 2020/10/15(木) 16:32
データがどれだけあるか分かりませんが、一旦データを日付でソートしたら 検索範囲を少なくできそうですね。 （OK） 2020/10/15(木) 17:28
フォームから自作すると大変だと思うので、 まずはフィルタオプションをマクロ記録されてはどうでしょうか？ https://www.forguncy.com/blog/20170714_filteroption
セルに条件記入する ＝ フォームと同じ機能 を持たせることができるので、とっつきやすいと思いますよ！！ （稲葉） 2020/10/15(木) 17:52
フィルタオプションでのマクロ記録はやってみたのですが、
同一ファイル内にシートがある場合はできたのですが、
ＤＢだけのシートと抽出結果だけのシートを持たせることができず断念しました。
説明不足でしたが、
ＤＢのファイルには約50項目の列があり、データは50000件くらいあります。
?@50000件のデータを種別ごとに集計したシートがあります。
?Aその集計シートにボタンを追加し、期間等の条件を3つ入力し、
ヒットするものを別ファイルのＤＢから抽出したい。
というものなのですが…
（バムセ） 2020/10/16(金) 09:22
また、データ量の話ですが、フィルタオプションはかなり堅牢です。
オートフィルタでは超遅くなるものも、
フィルタオプションでは、さくさくとまではいきませんが、動くと思います。
3,40万行でも動作したと思います。
（γ） 2020/10/16(金) 09:33
＞ＤＢだけのシートと抽出結果だけのシートを持たせることができず断念しました。 γさんと被ってしまいますが、出来ますよ。 記録したマクロ提示いただければ、アドバイスできると思います。 （稲葉） 2020/10/16(金) 09:39
↓↓↓ボタンに登録した抽出のマクロは以下の通りです。
Sub ボタン1_Click()
'
' ボタン1_Click Macro
'
'
Range("C4").Select
End Sub
Sub Macro2()
'
' Macro2 Macro
'
'
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Sheets("aaaa").Columns("A:AU").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A9"), Unique:=False
End Sub
（バムセ） 2020/10/16(金) 09:57
以下のような条件でテストしました。 AU列まで適当なデータで埋めてます。
テストデータ（シート名aaaa）
|[A] |[B] |[C] |[D] |[E]
[1] |日付 |従業員ID|学歴 |項目1|項目2
[2] |2020/10/16|10000801|辺境大学 | 9| 2
[3] |2020/10/16|10000802|米花大学 | 5| 7
[4] |2020/10/16|10000803|ホルモン大学| 5| 3
[5] |2020/10/17|10000804|辺境大学 | 6| 1
[6] |2020/10/17|10000805|米花大学 | 8| 4
[7] |2020/10/17|10000806|ホルモン大学| 7| 5
[8] |2020/10/18|10000801|辺境大学 | 4| 8
[9] |2020/10/18|10000802|米花大学 | 2| 3
[10]|2020/10/18|10000803|ホルモン大学| 1| 2
検索条件シート
|[A] |[B] |[C] |[D] |[E]
[1]|日付 |日付 |従業員ID|学歴 |
[2]|>=2020/10/16|<=2020/10/17|10000804|辺境*|
[3]| | | | |
出力シート
|[A] |[B] |[C] |[D] |[E]
[1]|日付 |従業員ID|学歴 |項目1|項目2
[2]|2020/10/17|10000804|辺境大学| 6| 1
[3]| | | | |
コード（標準モジュール）
コメント部分は自分の条件に合わせて変更してください。
Sub 検索テスト()
Dim wsDB As Worksheet
Dim wsCri As Worksheet
Dim wsOP As Worksheet
Dim rngCri As Range
Set wsDB = Sheets("aaaa") '<--出力先のシート名
Set wsCri = Sheets("検索条件") '<--条件を入力するシート名
Set wsOP = Sheets("出力") '<--出力先のシート名
wsOP.Activate '<--出力先のシートをアクティブにする
'==複雑な検索条件が必要なら、ここが作り込み必要
Set rngCri = wsCri.Range("A1:D2") '<--仮に日付の範囲、従業員番号、学歴指定 AND条件のみ
'==
wsDB.Columns("A:AU").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngCri, _
CopyToRange:=wsOP.Range("A1:AU1"), _
Unique:=False
MsgBox "出力完了しました"
End Sub
（稲葉） 2020/10/16(金) 10:25
伝え忘れましたが、出力シートの項目名は自分で必要な分を埋めてください。 項目名を並べ替えたり（日付と従業員IDの列を入れ替える） 減らす（大学名を項目名から無くす）と、その形で出力されるのでお勧めです。 （稲葉） 2020/10/16(金) 10:28
ＡのブックにＤＢシート
Ｂのブックに項目ごとの合計金額等をまとめた一覧表のシート
Ｂのブックに抽出条件を入れてボタンを押すとＣのブックに抽出されたシートが作成される。
（またＣのブックを開くときにはパスワードを求められる）
ややこしくて申し訳ありませんが、これはマクロで可能なのでしょうか？
（バムセ） 2020/10/16(金) 11:18
出力されたデータをコピーして貼り付けたらどうですか？ 以下のマクロ記録してみてください
↑のコードで出力されたデータのA1を選択する Ctrl+* を押す Ctrl+Cでコピー ブックを開き、貼り付けたいところにCtrl+V（または形式を選択して貼り付け） （稲葉） 2020/10/16(金) 11:23
不特定多数の人が見られるのはＢのブック
Ａのブック全ての詳細な情報が入っているため管理者（私）しかみられないようにし、
Ｃのブックは特定の人（指名者）にパスワードを連絡して開くときに入力してもらう…
といった形にするのが理想なのですが…
明細が出力されるシートが同じブックにあるとまずいのです。
（バムセ） 2020/10/16(金) 11:48
今はＡブックですよね？ それを条件を絞ってＢブックにコピーしたいと認識してお話しております。
再度になりますが ＞（稲葉） 2020/10/16(金) 10:28 でお伝えした通り、 フィルターオプションでは、項目を減らして出力することができます。 減らした項目をコピーしてＢブックに張り付けるならば問題ないのではないでしょうか？
そうではなくて・・・・
Ｂブック（不特定多数）から検索条件を指定して、「アクセス権を制御しているＡブック」の中を検索させるとお考えならば、無理です。 何のためのアクセス権はわかりません。
そのような運用をお考えでしたら、ＡブックからＢブック（またはＤブック）に必要最低限の情報だけ出力して、Ｂブックから出力したデータを参照させる方法が考えられます。 （稲葉） 2020/10/16(金) 12:02
>ややこしくて申し訳ありませんが、これはマクロで可能なのでしょうか？
可能です。
というか、手動でやれれば、その手動での操作を自動化するのがマクロです。
手動では、やり方はともかくできますよね？
で、「自動で間違いない結果を出したい（できれば簡単に素早く）」がテーマですよね？
ならば、その操作をVBAというプログラミング言語を使って自動で間違いなく何度でも実行するよう、
プログラムするだけです。
ただ、その前に前提条件の整理と、
結果を出す手順を概略整理しておく必要があります。（作りながら微調整が必要になってくると思います）
前提条件としては、
1）マクロを書いておくブック（シートに抽出条件入力欄等を作る）
2）簡易データベースとしてデータを置いておくブック
3）すでに集計されたデータがあるブック
4）結果を書き込むブック（新規作成、パスワード付き）
という4つのブックで運用するということですよね？
で、やりたいことの大まかな流れは、
1）条件の入力
2）条件により新規ブックにデータを抽出
3）抽出したデータに紐づく集計データを補完
4）新規ブックをパスワード付きで名前を付けて保存
と、いうことですよね？
とりあえずここまで決まったら、
今度はやりたいことの個別の細かい手順について整理していきます。
上記の2の部分は、他の方のアドバイスにあるように、
フィルターオプションを使うと勉強する量が少なくてアプリの開発が楽になります。
手動で使うと、すぐエラーが出て、なかなか期待した結果が得られなくて、
くじけそうになりますが、使い方にちょっと癖があるので、
「できないのかな？」と思いなかなか使おうと思いませんが、
vbaのコードにすると、短いコードで済むので開発が楽です。
1）結果書き込み用ブックを新規に開く
2）入力した条件を、フィルターオプションの条件欄＆出力用タイトル行の成形
3）フィルターオプションで抽出
となると思います。まずはここまでやってみてはいかがでしょうか？
その時に回答者と同じ環境で動作確認できるようサンプルデータや条件入力用シートのイメージ
等も併せて提示されると、同じデータで同じように動作確認ができるようにされることをお勧めします。
よく、データは提示できないと、伏字や変な置き換え文字で提示される方がおられますが、
話に齟齬が出て、話が通じにくい場合が出てきます。
そういうことがないようにされると、学習が進みやすいかと思います。
（まっつわん） 2020/10/16(金) 12:49
●Aブック：（DBとなるブックです）※これは私しか開けないブックです。
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[2] |1 |10000801|辺境大学 | 9| 2
[3] |2 |10000802|米花大学 | 5| 7
[4] |3 |10000803|ホルモン大学| 5| 3
[5] |4 |10000804|辺境大学 | 6| 1
[6] |1 |10000805|米花大学 | 8| 4
[7] |3 |10000806|ホルモン大学| 7| 5
[8] |4 |10000801|辺境大学 | 4| 8
[9] |2 |10000802|米花大学 | 2| 3
[10]|6 |10000803|ホルモン大学| 1| 2
●Bブック：↑Aブックを基に大学ごとに一覧表（集計表）を作っています。
これは
＜辺境大学＞
|4月|5月|6月|7月|8月
[項目1]|20 |10 |30 |10 |20・・・
[項目2]|20 |10 |30 |10 |20・・・
★ここに、検索条件用セルとボタンをつけたいです。
＜辺境大学＞
検索条件A（月）
検索条件B（項目名）
検索条件C（大学名）←※固定 □←マクロ登録ボタン
|4月|5月|6月|7月|8月
[項目1]|20 |10 |30 |10 |20・・・
[項目2]|20 |10 |30 |10 |20・・・
そして、□のマクロボタンを押すと、Cのブックに
データが抽出されるようにしたいのです。（Cのブックは開くときにパスワードが必要）
Cブック：Aブックを元に明細を表示するが、条件はBブックで指定
Aブックの表示したい項目だけを選べれば最高です。
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|項目1|項目2|項目3・・・
[2] |1 |10000801| 9 | 2| 5
[3] |2 |10000802| 5 | 7| 2
[4] |3 |10000803| 5 | 3| 4
こんなイメージです。
担当者にはBブックを送りますが、担当者はCブックにより、
他の大学の明細は見られないようにしたいのです。
集計されたデータは見られても内訳がないのでOK。
（バムセ） 2020/10/16(金) 13:40
Ｂブックの人は、Ａブックを見てはいけないのでしたら、 Ａブックから一度項目を絞ってあげないといけないので、Ｄブックを作ります。
それを踏まえたうえで、 Ａ＞Ｄ＞Ｂ＞Ｃという管理順番で理解致します。
Ａブック：バムセさんのみ 全情報 Ｄブック：対象月 従業員ＩＤ 学歴 項目1〜2を許可 <--ＤＢＣブック閲覧許可 Ｂブック：対象月 従業員ＩＤ 学歴 項目1を許可 <--ＤＢＣブック閲覧許可 Ｃブック：対象月 従業員ＩＤ 項目1を許可 <--Ｃブック閲覧許可 ＆ パスワード付
■テスト環境
A〜Dブックを作成
Aブック：DBシートを作成し、対象月,従業員ID,学歴,項目1,項目2 の項目を設定し
（バムセ） 2020/10/16(金) 13:40 で表示されたダミーデータを入れておく
Bブック：検索条件シートを作成し
|[A] |[B] |[C]
[1]|対象月|項目1|学歴
[2]| 1| |辺境*
と条件を設定しておく
Cブック：データ出力シートを作成しておく
Dブック：DBシートを作成しておく
■Ａブックに以下のプログラムを入れる
Sub Dブック出力()
'//Ａブック用プログラム
'//Ｄブックに情報が制限されたデータベースを渡す
Dim tbl As Variant
Dim fn As String
Dim wb As Workbook
Dim aryfld As Variant
Dim tmpWS As Worksheet
'
'//ブックのフルパスを指定する
Const opFN As String = "C:\Users\****\Desktop\Dブック.xlsm"
'
'//出力する項目名をカンマ区切りの文字列で指定
Const fld = "対象月,従業員ID,学歴,項目1"
'
'//ブックを開いて
fn = Dir(opFN)
If fn = "" Then
MsgBox "出力先のファイルが存在しません"
Exit Sub
End If
On Error Resume Next
Set wb = Workbooks(fn)
On Error GoTo 0
If wb Is Nothing Then Set wb = Workbooks.Open(opFN)
'
aryfld = Split(fld, ",")
With ThisWorkbook
'//作業用シートを作る
.Sheets.Add after:=.Sheets(.Sheets.Count)
Set tmpWS = .Sheets(.Sheets.Count)
tmpWS.Activate
tmpWS.Range("A1").Resize(, UBound(aryfld) + 1).Value = aryfld
'
'//AブックのDBシートのAE列から、fldで指定したデータをすべて作業用シートに抜き出す
.Sheets("DB").Columns("A:E").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.Sheets(.Sheets.Count).Range("A1:A2"), _
CopyToRange:=tmpWS.Cells(1).CurrentRegion, _
Unique:=False
'
'抜き出したシートをtbl変数に入れる
tbl = .Sheets(.Sheets.Count).Cells(1).CurrentRegion.Value
Application.DisplayAlerts = False
tmpWS.Delete
Application.DisplayAlerts = True
End With
'DブックのDBシートにAブックのfldで指定したデータを落とし込む
With wb.Sheets("DB")
.Cells.Clear
.Cells(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
.Parent.Save '<--上書き保存
End With
MsgBox "データベースの抜出が完了しました"
End Sub
■Bブックに以下のプログラムを入れておく
（10/17 10:18修正）
（10/20 8:39全面差し替え）
Sub Cブック出力()
'//Ｃブックに、Ｂブックの条件で、Ｄブックの情報を渡す
Dim tbl As Variant
Dim fn1 As String
Dim fn2 As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim tmpWS As Worksheet
Dim aryfld As Variant
Dim pw As String
'
'//ブックのフルパスを指定する
Const opFN1 As String = "C:\Users\****\Desktop\Cブック.xlsm"
Const opFN2 As String = "C:\Users\****\Desktop\Dブック.xlsm"
'
'//出力する項目名をカンマ区切りの文字列で指定
Const fld = "対象月,従業員ID,項目1"
'
'//Cブックを開くパスワードの設定
pw = InputBox("パスワードを設定してください")
If pw = "" Then
MsgBox "パスワードが設定されませんでした。プログラムを終了します"
Exit Sub
End If
'
'//ブックを開いて
fn1 = Dir(opFN1)
fn2 = Dir(opFN2)
If fn1 = "" Or fn2 = "" Then
MsgBox "出力先またはデータベースのファイルが存在しません"
Exit Sub
End If
On Error Resume Next
Set wb1 = Workbooks(fn1)
Set wb2 = Workbooks(fn2)
On Error GoTo 0
If wb1 Is Nothing Then Set wb1 = Workbooks.Open(opFN1)
If wb2 Is Nothing Then Set wb2 = Workbooks.Open(opFN2)
'
aryfld = Split(fld, ",")
With ThisWorkbook
'//作業用シートを作る
.Sheets.Add after:=.Sheets(.Sheets.Count)
Set tmpWS = .Sheets(.Sheets.Count)
tmpWS.Activate
tmpWS.Range("A1").Resize(, UBound(aryfld) + 1).Value = aryfld
'
'//DブックのDBシートのAE列から、fldで指定したデータをすべて作業用シートに抜き出す
wb2.Sheets("DB").Columns("A:E").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.Sheets("検索条件").Range("A1:C2"), _
CopyToRange:=tmpWS.Cells(1).CurrentRegion, _
Unique:=False
'
'抜き出したシートをtbl変数に入れる
tbl = tmpWS.Cells(1).CurrentRegion.Value
Application.DisplayAlerts = False
tmpWS.Delete
Application.DisplayAlerts = True
End With
'Cブックのデータ出力シートにDブックのfldで指定したデータを落とし込む
With wb1.Sheets("データ出力")
.Cells.Clear
.Cells(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
.Parent.Password = pw
.Parent.Save '<--上書き保存
End With
MsgBox "データベースの抜出が完了しました"
End Sub
■テスト方法 １）各コードのConstに、作成したブックのフルパスを入れておいてください。（可変しない前提） ２）fldにカンマ区切りの項目名を入れておいてください ３）Ａブックのみを開き、プログラムを実行する ４）Ｄブックにデータが転送されます。 ５）Ａ、Ｄブックを閉じて、Ｂブックを開いてください ６）Ｂブックの検索条件を入れてください ７）Ｂブックのプログラムを実行してください ８）パスワードを聞かれますので、忘れない様にメモを取ってください ９）Ｃブックにデータが転送されます。
上記の内容でよければ、まずは本番環境に合わせて各コードを変更してください。 わからなければ聞いてください。
（稲葉） 2020/10/16(金) 18:42
いや、作り込まないでまずはテストしてみて・・・ 認識にずれがあると、無意味なので （稲葉） 2020/10/19(月) 12:40
|[A] |[B] |[C]
[1]|対象月|項目1|学歴
[2]| 1| |辺境*
として保存しているのに、
Ａブックからプログラムを作動すると
Bブック：検索条件シートを作成し
|[A] |[B] |[C]
[1]|対象月|従業員ＩＤ|項目1
[2]| 1| |辺境*
に置き換わってしまいます。
どこを修正すればいいのでしょうか？
（バムセ） 2020/10/19(月) 15:39
テストできる環境にいまいないの明日まで待ってください AブックからBブックは操作してないので、そんなことはないと思いますが、、、
.Range("A1").Resize(, UBound(aryfld)).Value = aryfld
.Range("A1").Resize(, UBound(aryfld)+1).Value = aryfld
cブック出力プロシジャのミスがあったので、上記書き換えお願いします
（稲葉） 2020/10/19(月) 20:09
すみません、こっちのミスでした Sheets.Add(Sheets.Count) を常套句で使っていましたが、今回アクティブなブックと処理したいブックが異なっていたので .Sheets.Add(.Sheets.Count) といくつか修正しました。
Aブックのプログラムも修正必要なので、少々お待ちください （稲葉） 2020/10/20(火) 08:42
先ほど、全部差し替えました。 再度テストのほうお願いいたします。m(__)m （稲葉） 2020/10/20(火) 08:55
修正後、問題なく、作動しました。
これでいけそうです！！！
こちらで相談して良かったです。
本当にありがとうございました。
（バムセ） 2020/10/20(火) 10:55
Ｂブック（自由閲覧可能）でプログラムを実行すると、
自動的にＤブックとＣブックが開いてしまいます。
（Ｂブックは大学別にシートを作成し、それぞれのシートにボタンを付けて、
Ｃブックができるようにしようと思っています。
他大学の情報は、自分の大学以外の人に見られないようにするため）
Ｂブックで命令した後、
閲覧者（制限ある人）が、Ｃブックを開きにいかないと閲覧できないようにはできますか？
（Ａブックの後、Ｄブックが開くのは構いません。）
閲覧可能なのはＢブックとＣブック。
また、ＣブックはＢブックを閉じた後でないと開けない。。。
といった具合にしたいと思っています。
説明が下手でわかりづらいかもしれませんが、伝わりますでしょうか？？
（一番最初にＤブック、ＣブックがＤＢＣブック閲覧可能とあったのに、
今になって申し訳ありません。）
（バムセ） 2020/10/20(火) 11:46
Ｂブックで検索する人が、ＤブックとＣブックを見ることができるのはＮＧってことですか？ （稲葉） 2020/10/20(火) 12:02
といったようにしたいのです。
今は、Ｂブックでプログラムを実行すると、
ＤブックとＣブックが開いてしまうので、パスワードの設定をしているのに、
入力しなくても見れてしまうのです。
今でも、全部閉じてからＣブックを開くとパスワードが求められるのでそれはＯＫです。
（バムセ） 2020/10/20(火) 12:36
＞【Ｂブックで検索する人】 ＞Ｄブック：閲覧不可 ＞ （↑ここではＣブックは見られない） これは無理かなぁ・・・ 理由として １）Ｄブックから情報をとる以上、開かざるを得ない ２）ＶＢＡで表示しないまま制御してもよいが、何らかの影響でＶＢＡが止まった場合、どうしても開いたままになってしまう。 ３）仮に２）のシートをveryhiddenで隠しても、悪意のある人からは見ることができてしまう
Ａ→Ｄの段階で、見られてもいい情報だけ置くことはできないんですか？ あとは、ＢとＤを統合して、フィールドまたはレコードごとに見られてもいい情報をブックを分散して配置する
どの程度のセキュリティ強度を求めるかによると思いますが、現時点では難しいです。
（稲葉） 2020/10/20(火) 12:45
ついでに、Ｂブックを作る人がパスワード設定しているのに、Ｃブックを見られないようにするっていうのが意味不明です。 （稲葉） 2020/10/20(火) 12:46
基本的なことをすみません。
Ｃブックはどこからデータをひっぱってくるのでしょうか？？＿
（バムセ） 2020/10/20(火) 12:58
そのため、ＢブックでＣブックが見れるとなると、
辺境大学の人がホルモン大学の人のデータを見れてしまいませんか？（違っていたらすみません）
（バムセ） 2020/10/20(火) 13:04
私から提案できるのは３択です Ｘ案）ＶＢＡで制御して、止まった時にＤブックが開いたままになってしまうのを許容する なるべく開いたままにしない様にコーディングするが、可能性は0ではない Ｙ案）大学ごとにブックを分けて、それぞれＯＳレベルでアクセス権を設定したフォルダに入れてしまう。 セキュリティ強度が高くておすすめ Ｚ案）諦める
以下返信です。
＞辺境大学の人がホルモン大学の情報をみてはいけないのですが、 ＞辺境大学の人は辺境大学のすべてのデータが見られるようにしたいのです。 であれば、大学ごとにブックを分けて、アクセス権で分けるほかないと思います。
＞そのため、ＢブックでＣブックが見れるとなると、 Ｃブックを作る人がパスワード設定するのですから、悪意ある人が他の大学のシートを使えば同じことでは？
繰り返しになりますが、どこまでセキュリティ強度を上げるかによると思います。
１）Ｄブックから情報をとる以上、開かざるを得ない ２）ＶＢＡで表示しないまま制御してもよいが、何らかの影響でＶＢＡが止まった場合、どうしても開いたままになってしまう。 ３）仮に２）のシートをveryhiddenで隠しても、悪意のある人からは見ることができてしまう
この3つのうち、どこまで妥協できるかによると思います。
あとは別案の ＞ＢとＤを統合して、フィールドまたはレコードごとに見られてもいい情報をブックを分散して配置する 分散配置したブックは、それぞれアクセス権が設定されたフォルダに入れる
（稲葉） 2020/10/20(火) 13:36
少し周囲との相談・検討が必要ですね。。
例えば、Ｘ案で行きたい場合、どの部分を修正すればできますでしょうか？
（バムセ） 2020/10/20(火) 13:40
Ｘ案の場合 Ｄブック ・ＤＢシートをVeryHiddenで隠して、VBA以外からは存在がないものとして扱う ・ブックに複雑なパスワードをかけて、Bブックからしか開けないようにする Ｂブック ・各大学の所属でないと抽出できない様に、プログラム実行前に、大学ごとに複雑なパスワードを設定 ・条件フィールドはVeryHiddenシートに設定し、勝手に書き換えられないようにブックをパスワードで保護 ・エラーになった場合、Ｄブック、Ｃブックを閉じるように締め処理を追加（デバッグができなくなる） ・上記プログラムが書き換えられない様に、VBProjectをパスワードで保護
VBProjectのパスワードを忘れた場合、もう直せません。 また、大変申し訳ないですが 私がコーディングしたとしても、自分の仕様通りに変更を加えることをバムセさんができるとは思えないです・・・。
（稲葉） 2020/10/20(火) 14:06
別の方法を考えたいと思います。
これまで、たくさんお時間をいただきありがとうございました。
（バムセ） 2020/10/20(火) 14:15
こちらこそ、お力になれずすみません。 もし、リアルタイムで出力されなくてもよいなら、 Bブックの検索条件を管理者にメール等で送って、 管理者が情報を制限したCブックを出力し、 パスワードは別途閲覧者に送る
アナログですが、一番簡単です。 （稲葉） 2020/10/20(火) 16:40
再度書いてみます。
前提条件としては、
1）マクロを書いておくブック（シートに抽出条件入力欄等を作る）
2）簡易データベースとしてデータを置いておくブック
3）すでに集計されたデータがあるブック
と3つ現状エクセルファイルがあるということですよね？
で、
BブックはみれてCブックは見れないようにするとかのような運用は通常しません。
簡易データベースとして利用する、
2と3のファイルはユーザーには触れないようにするし、
触る必要がないようにマクロを作ります。
見せたくなければパスワードを設定したり、隠しファイルに設定したりしておきます。
で、
マクロからデータベースとして使うファイルを開くようにし、
開いたときは非表示にし、
見せてもいいデータだけ取り出し、マクロのあるブックに表示し、
データベースのファイルを閉じる。
というようなことをしてやれば、
各パソコン名で、
閲覧可能なデータの表示をレベルごとに管理できると思います。
当然入力も、マクロで制御し、
データベースとして使うファイルはユーザーに触らせません。
そういう風にエクセルの操作を制限し、間違いがないようなアプリを作ることになります。
>この改善は私にはハードルが高すぎたようです… 0から勉強しながら、アプリの開発をするならば、 数か月〜1年以上かかるかも知れません。 アプリの開発だけに専念できるなら、 1か月かからないかも知れませんが、 気長に取り組まれた方がよいと思います。 （まっつわん） 2020/10/20(火) 17:54
（まっつわん様）
ありがとうございます。
＞0から勉強しながら、アプリの開発をするならば、
数か月〜1年以上かかるかも知れません。
アプリの開発だけに専念できるなら、
1か月かからないかも知れませんが、
気長に取り組まれた方がよいと思います。
全く仰る通りです。
本を購入してみたり、ネットで例がないか検索したりしていますが、
基本的な知識がないので、理解できてないまま進めようとしていました。
ここにいらっしゃる方は博識な方が多いので、お恥ずかしい限りです。
【考え方を変えて、以下の方法は可能でしょうか？】
（１）Ａブック（バムセのみ閲覧）のＤＢシートで条件入力をし、
Ａブックの別シートに大学別シートを自動で作成することはできますか？
（ひとつの大学だけであれば、シートが作成できるコードは作成できましたが、
ネット上に、ある一定の条件ごと（たとえば5列目の種類別）にシートを作成することができるような記 載があったのですが、参考となるコードがなく、わかりませんでした）
（２）Ａブックで大学ごとに作成されたシート（ホルモン大学シート、辺境大学シート）をホルモン大学、辺境大学…のブック（各大学ブック）に転記することはできますか？
（大学ごとにブックを作成しそのブック自体にパスワードを設定し、担当者にパスワードを連絡）
（今のところ、22種類（22ブック）です）
何度も申し訳ありませんが、もう一度お力をお借りしたくよろしくお願い致します。
（バムセ） 2020/10/21(水) 11:44
こいつを
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[2] | 1|10000801|辺境大学 | 9| 2
[3] | 2|10000802|米花大学 | 5| 7
[4] | 3|10000803|ホルモン大学| 5| 3
[5] | 4|10000804|辺境大学 | 6| 1
[6] | 1|10000805|米花大学 | 8| 4
[7] | 3|10000806|ホルモン大学| 7| 5
[8] | 4|10000801|辺境大学 | 4| 8
[9] | 2|10000802|米花大学 | 2| 3
[10]| 6|10000803|ホルモン大学| 1| 2
例なので、列ごとに分けてますが、
「シートごとに分けて」
さらに「ブックごとに分けてパスワードを設定する」
|[A] |[B] |[C] |[D] |[E] |[F]|[G] |[H] |[I] |[J] |[K] |[L]|[M] |[N] |[O] |[P] |[Q]
[1]|対象月|従業員ID|学歴 |項目1|項目2| |対象月|従業員ID|学歴 |項目1|項目2| |対象月|従業員ID|学歴 |項目1|項目2
[2]| 1|10000801|辺境大学| 9| 2| | 2|10000802|米花大学| 5| 7| | 3|10000803|ホルモン大学| 5| 3
[3]| 4|10000804|辺境大学| 6| 1| | 1|10000805|米花大学| 8| 4| | 3|10000806|ホルモン大学| 7| 5
[4]| 4|10000801|辺境大学| 4| 8| | 2|10000802|米花大学| 2| 3| | 6|10000803|ホルモン大学| 1| 2
という理解でよろしいですか？ （稲葉） 2020/10/21(水) 12:06
（１）ＤＢシートから、
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[2] | 1|10000801|辺境大学 | 9| 2
[3] | 2|10000802|米花大学 | 5| 7
[4] | 3|10000803|ホルモン大学| 5| 3
[5] | 4|10000804|辺境大学 | 6| 1
[6] | 1|10000805|米花大学 | 8| 4
[7] | 3|10000806|ホルモン大学| 7| 5
[8] | 4|10000801|辺境大学 | 4| 8
[9] | 2|10000802|米花大学 | 2| 3
[10]| 6|10000803|ホルモン大学| 1| 2
（２）辺境大学シート
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[2] | 1|10000801|辺境大学 | 9| 2
[5] | 4|10000804|辺境大学 | 6| 1
[8] | 4|10000801|辺境大学 | 4| 8
（３）米花大学シート
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[3] | 2|10000802|米花大学 | 5| 7
[6] | 1|10000805|米花大学 | 8| 4
[9] | 2|10000802|米花大学 | 2| 3
（４）ホルモン大学シート
|[A] |[B] |[C] |[D] |[E]
[1] |対象月|従業員ID|学歴 |項目1|項目2
[4] | 3|10000803|ホルモン大学| 5| 3
[7] | 3|10000806|ホルモン大学| 7| 5
[10]| 6|10000803|ホルモン大学| 1| 2
の（２）（３）（４）の３つを自動作成するということです。
そしてその（２）（３）（４）のシートを
パスワードをかけた辺境大学ブック、米花大学ブック、ホルモン大学ブックに自動転記する。
という感じです。
（バムセ） 2020/10/21(水) 12:42
途中で説明書き力尽きました・・・
１）ＡブックにDBシートとパスワードシートを作ってください。
パスワードシートは以下のような造りにしてください。（空白の場合は、パスワードなし）
|[A] |[B]
[1]|学歴 |パスワード
[2]|辺境大学 |abcd
[3]|ホルモン大学|efgh
[4]|米花大学 |ijkl
２）一度大学ごとのブックを削除します。 狙い→開く処理の時に、パスワードを間違えて開けない等トラブルが予想されるため 削除できない場合は、処理を中断 ３）オートフィルタを使って、各シートに転記 既存のデータは消されて、新しいデータのみ残ります。 ４）３）で作成したシートをコピーして、新しいブックとして、パスワードを付けて保存します。
Sub test()
Dim app As Application
Dim tbl As Variant
Dim pwtbl As Variant
Dim ws As Worksheet
Dim pwws As Worksheet
Dim fldws As Worksheet
Dim nopwMsg As String
Dim tmppw As Variant
Dim fp As String
Dim ifld As Variant
Dim dic As Object
Dim i As Long
Dim fld As Variant
'//設定
Set app = Application
Set ws = Sheets("DB")
Set pwws = Sheets("パスワード")
fp = ThisWorkbook.Path '<--大学のフォルダがあるフォルダパス
'
'---------------エラー処理---------------
'//「学歴」項目が何列目か調べる
ws.Activate
ifld = [match("学歴",1:1,0)]
If IsError(ifld) Then Exit Sub
'
'//大学名の重複無一覧を作り、パスワードの有無を調べる
tbl = ws.Range(ws.Cells(2, ifld), ws.Cells(Rows.Count, ifld).End(xlUp)).Value
pwtbl = pwws.Range("B1", pwws.Cells(Rows.Count, "A").End(xlUp)).Value
nopwMsg = ""
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
If Not dic.exists(tbl(i, 1)) Then
tmppw = app.Index(pwtbl, app.Match(tbl(i, 1), app.Index(pwtbl, 0, 1), 0), 2)
If IsError(tmppw) Then
nopwMsg = nopwMsg & tbl(i, 1) & vbCrLf
dic(tbl(i, 1)) = ""
Else
dic(tbl(i, 1)) = tmppw
End If
End If
Next i
If nopwMsg <> "" Then
MsgBox "パスワードが設定されていない大学があります。処理を中断します。" & vbCrLf & nopwMsg
Exit Sub
End If
'
'//大学ごとのブックを削除する
For Each fld In dic.keys
If Dir(fp & "\" & fld & ".xlsx") <> "" Then
On Error Resume Next
Kill fp & "\" & fld & ".xlsx"
If Err.Number <> 0 Then
MsgBox "ブックの削除に失敗しました。処理を中断します" & fld
Exit Sub
End If
On Error GoTo 0
End If
Next fld
'---------------エラー処理ここまで---------------
'
'//本番処理大学ごとにループ処理
For Each fld In dic.keys
'//大学のシートの有無を調べる
If Application.Evaluate("NOT(ISREF(" & fld & "!A1))") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = fld
Set fldws = Sheets(fld)
fldws.Cells.ClearContents
'
'//DBを大学名でオートフィルタし、各大学ごとのシートに割り振る
With ws.Range("A1").CurrentRegion
.AutoFilter ifld, fld
.Copy fldws.Range("A1")
End With
'
'//シートをコピーして、パスワードを設定して保存し、ブックを閉じる
fldws.Copy
With ActiveWorkbook
.SaveAs _
Filename:=fp & "\" & fld & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, _
Password:=dic(fld)
.Close
End With
Next fld
If ws.AutoFilterMode = True Then ws.ShowAllData
MsgBox "処理が完了しました"
End Sub
（稲葉） 2020/10/21(水) 13:50
このコードを見て、しっかり勉強していきたいと思います。
本当に、本当にありがとうございました。
（バムセ） 2020/10/21(水) 14:20
'---------------エラー処理ここまで---------------
'
'//本番処理大学ごとにループ処理
For Each fld In dic.keys
'//大学のシートの有無を調べる
If Application.Evaluate("NOT(ISREF(" & fld & "!A1))") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = fld
Set fldws = Sheets(fld)
fldws.Cells.ClearContents
の、
Set fldws = Sheets(fld)
部分が黄色くﾊｯﾁﾝｸﾞされていました。
テストでは何事もなく３つとも大学シートができて、パスワードも完ぺきだったんですが…
本番データにしたときに何がまずかったんでしょうか。
（バムセ） 2020/10/21(水) 14:59
＞ '//本番処理大学ごとにループ処理
＞ For Each fld In dic.keys
ここを
'//本番処理大学ごとにループ処理
ThisWorkbook.Activate '<--追加
For Each fld In dic.keys
に変更してもらって
それでもエラーで止まったら、ローカルウィンドウを開いて、 fldにどのような値が入っているか教えてください。
（稲葉） 2020/10/21(水) 18:14
一旦、今設定しているすべてのコードを貼り付けておきます。
Sub 転送()
Dim app As Application
Dim tbl As Variant
Dim pwtbl As Variant
Dim ws As Worksheet
Dim pwws As Worksheet
Dim fldws As Worksheet
Dim nopwMsg As String
Dim tmppw As Variant
Dim fp As String
Dim ifld As Variant
Dim dic As Object
Dim i As Long
Dim fld As Variant
'//設定
Set app = Application
Set ws = Sheets("DB")
Set pwws = Sheets("パスワード")
fp = ThisWorkbook.Path '<--大学のフォルダがあるフォルダパス
'
'---------------エラー処理---------------
'//「学歴」項目が何列目か調べる
ws.Activate
ifld = [match("学歴",1:1,0)]
If IsError(ifld) Then Exit Sub
'
'//大学名の重複無一覧を作り、パスワードの有無を調べる
tbl = ws.Range(ws.Cells(2, ifld), ws.Cells(Rows.Count, ifld).End(xlUp)).Value
pwtbl = pwws.Range("B1", pwws.Cells(Rows.Count, "A").End(xlUp)).Value
nopwMsg = ""
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
If Not dic.exists(tbl(i, 1)) Then
tmppw = app.Index(pwtbl, app.Match(tbl(i, 1), app.Index(pwtbl, 0, 1), 0), 2)
If IsError(tmppw) Then
nopwMsg = nopwMsg & tbl(i, 1) & vbCrLf
dic(tbl(i, 1)) = ""
Else
dic(tbl(i, 1)) = tmppw
End If
End If
Next i
If nopwMsg <> "" Then
MsgBox "パスワードが設定されていない大学があります。処理を中断します。" & vbCrLf & nopwMsg
Exit Sub
End If
'
'//大学ごとのブックを削除する
For Each fld In dic.keys
If Dir(fp & "\" & fld & ".xlsx") <> "" Then
On Error Resume Next
Kill fp & "\" & fld & ".xlsx"
If Err.Number <> 0 Then
MsgBox "ブックの削除に失敗しました。処理を中断します" & fld
Exit Sub
End If
On Error GoTo 0
End If
Next fld
'---------------エラー処理ここまで---------------
'
'//本番処理大学ごとにループ処理
For Each fld In dic.keys
'//大学のシートの有無を調べる
If Application.Evaluate("NOT(ISREF(" & fld & "!A1))") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = fld
Set fldws = Sheets(fld)
fldws.Cells.ClearContents
'
'//DBを大学名でオートフィルタし、各大学ごとのシートに割り振る
With ws.Range("A1").CurrentRegion
.AutoFilter ifld, fld
.Copy fldws.Range("A1")
End With
'
'//シートをコピーして、パスワードを設定して保存し、ブックを閉じる
fldws.Copy
With ActiveWorkbook
.SaveAs _
Filename:=fp & "\" & fld & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, _
Password:=dic(fld)
.Close
End With
Next fld
If ws.AutoFilterMode = True Then ws.ShowAllData
MsgBox "処理が完了しました"
End Sub
次は、●の部分でｴﾗｰになりました。
'//DBを大学名でオートフィルタし、各大学ごとのシートに割り振る
With ws.Range("A1").CurrentRegion
● .AutoFilter ifld, fld
.Copy fldws.Range("A1")
End With
実際にフィルターをかける項目の「学歴」が入っている列はＳ列になります。
（バムセ） 2020/10/22(木) 10:43
あとはデータ見ないとわからないですが、以下確認してください。 A1からS1（学歴）まで項目が連続しているか →連続していないなら、もはやデータベースじゃないです
https://www.239-programing.com/excel-vba/basic/basic023.html
行き詰ったら↑のサイト見てできる範囲で理解してください。 （稲葉） 2020/10/22(木) 12:53
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.