[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『リストと同じシート名を別のエクセルファイルにコピーする方法を教えてください！』（tama）
各シート名に、社員の名前が記載されたエクセルファイル[1]があります。
Sheet1のシート名が「田中」
Sheet2のシート名が「鈴木」
Sheet3のシート名が「高橋」
Sheet4のシート名が「佐藤」
Sheet5のシート名が「新井」
これを担当部署ごとに新規エクセルファイルを作成し、そこにシートをコピーするVBAを教えていただきたいです。
新規エクセルファイル[2]を「営業部」として
Sheet1「田中」
Sheet2「鈴木」
のシートをコピー
新規エクセルファイル[3]を「総務部」として
Sheet3「高橋」
Sheet4「佐藤」
のシートをコピー
新規エクセルファイル[4]を「人事部」として
Sheet5「新井」
のシートをコピー
このVBAを実行するエクセルファイル[5]に「マスタ」(リスト)があるので、そこから判別させたいです。
A1：営業部
A2：田中
A3：鈴木
A4：高橋
B1：総務部
B2：高橋
B3：佐藤
C1：人事部
C2：新井
といったリストです。
どうぞよろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
現在は、以下のような処理をしているのですが、
プロシージャを編集しなくても処理できるような仕組みにしたいと思っております。
そこでリストの名前参照して処理をするFor Nextを使用しとうと思ったのですが、
使えそうな例文がなく、困り果ててしまいました。
VBA初心者です。どうぞよろしくお願いいたします。
Sub ファイルを分割する()
Application.ScreenUpdating = False
Dim bookname As String
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*")
Workbooks.Open ThisWorkbook.Path & "\全社員データ\" & bookname
Sheets(Array("田中", "鈴木")).Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後\" & "営業部用" & ".xlsx"
ActiveWorkbook.Close
ActiveWorkbook.Close
MsgBox "分割できました"
End Sub
（tama） 2021/10/05(火) 14:18
エクセルファイル１．xlsx ├Sheet1（田中） ├Sheet2（鈴木） ├Sheet3（高橋） ├Sheet4（佐藤） └Sheet5（新井）
エクセルファイル5.xlsm └Sheet1（マスタ）
【マスタ】シートのレイアウト
__A___ __B___ __C___
1 営業部 総務部 人事部
2 田中 高橋 新井
3 鈴木 佐藤
4 高橋
普通にマスタシートの列と行を２重ループにして処理すれば、さほど難しいことはないとおもいますが如何でしょうか？
Sub さんぷる()
Dim 行 As Long, 列 As Long
Dim dstWB As Workbook
Stop 'ブレークポイントの代わり
With ThisWorkbook.Worksheets("マスタ")
For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
Set dstWB = Workbooks.Add(Template:=xlWBATWorksheet)
For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
Workbooks("エクセルファイル１.xlsx").Worksheets(.Cells(行, 列).Value).Copy after:=dstWB.Worksheets(dstWB.Worksheets.Count)
Next
Application.DisplayAlerts = False
dstWB.Worksheets(1).Delete
dstWB.SaveAs .Cells(1, 列).Value
Application.DisplayAlerts = True
dstWB.Close
Next
End With
End Sub
（もこな２） 2021/10/05(火) 14:57
アプローチとしてはそのままですが、
1. エクセル1からシート名を取得
2. 1で取得した項目数分ループ処理
2.1 項目をエクセル5からFindメソッドで検索し、部署を取得 2.2 新規ブック作成(すでにあるなら、開く(全体の処理終わるまで開いたままでもよい)) 2.3 エクセル1の対象シートを2.2で開いたブックにコピー 3. 開いたファイル等の保存処理
下記は、あげていただいたコードに無かった処理の基本例文です。
・新規ブック作成
Workbooks.Add ・コピー Call コピー元ブック変数.Sheets(シート名(もしくはインデックス)).Copy(before:=コピー先ブック変数.Sheets(シート名(もしくはインデックス)) ・マスタから部署取得 Set x = 検索対象シート変数.Cells.Find(what:=検索値) x.rowで検索値の行情報、x.columnsで列情報取得が可能 （ge） 2021/10/05(火) 15:07
まず、以下はまさにその通りでございます。
エクセルファイル１．xlsx（仮名：ファイル名がいつも違うので仮名とさせていただきました。） ├Sheet1（田中） ├Sheet2（鈴木） ├Sheet3（高橋） ├Sheet4（佐藤） └Sheet5（新井）
エクセルファイル5.xlsm
└Sheet1（マスタ）
【マスタ】シートのレイアウト
__A___ __B___ __C___
1 営業部 総務部 人事部
2 田中 高橋 新井
3 鈴木 佐藤
4 高橋
■現状
エクセルファイル１.xlsxというのは、ファイル名が統一されていないケースが多いので、
「VBA」というフォルダの中に、エクセルファイル5.xlsmを保存し、
「VBA」フォルダに、
・「全社員データ」フォルダ
・「分割後」フォルダ
を作成し、
「全社員データ」に、 エクセルファイル１．xlsxなるファイルを投入するようにしています。
そして、処理が完了すると、「分割後」というフォルダに入るようにしています。
現在は、リストを使用したプロシージャが書けないので、
標準モジュールを
・営業部用
・総務部用
・人事分用
に分けて、それぞれのプロシージャの中に、分けたいシート名を1つ1つ記載して、
各部署毎にボタンを作成し、「全社員データ」フォルダに保存したデータ（ 仮名：エクセルファイル１．xlsx）を、
各部署毎のファイルに分割しています。
■今後（やりたいことといたしまして）
現在のコードの、
Sheets(Array("田中", "鈴木","高橋")).Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後\" & "営業部用" & ".xlsx"
なる部分が、
・「A列のリストと同じシート名を検索してコピーし、"営業部用" & ".xlsx"を作成する」
・「B列のリストと同じシート名を検索してコピーし、"総務部用" & ".xlsx"を作成する」
・「C列のリストと同じシート名を検索してコピーし、"人事部用" & ".xlsx"を作成する」
となれば、部署異動があった時にプロシージャを開いて編集しなくても、マスタのリストを編集すれば使えるVBAになるのではないかと思い、
これができるコードを教えていただきたいと思っています。
現状のコードです↓-------------------------------------------
Sub ファイルを分割する営業部用()
Application.ScreenUpdating = False
Dim bookname As String
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*")
Workbooks.Open ThisWorkbook.Path & "\全社員データ\" & bookname
Sheets(Array("田中", "鈴木","高橋")).Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後\" & "営業部用" & ".xlsx"
ActiveWorkbook.Close ActiveWorkbook.Close
MsgBox "分割できました"
Application.ScreenUpdating = False
Dim bookname As String
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*")
Workbooks.Open ThisWorkbook.Path & "\全社員データ\" & bookname
Sheets(Array("高橋", "斎藤").Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後\" & "総務部用" & ".xlsx"
ActiveWorkbook.Close ActiveWorkbook.Close
MsgBox "分割できました"
Application.ScreenUpdating = False
Dim bookname As String
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*")
Workbooks.Open ThisWorkbook.Path & "\全社員データ\" & bookname
Sheets(Array("新井").Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後\" & "人事部用" & ".xlsx"
ActiveWorkbook.Close ActiveWorkbook.Close
MsgBox "分割できました"
ボタンは部署毎にあっても良いと思っていますが、
コピーするシート名は、マスタ（リスト）から検索したいです。
何卒よろしくお願いいたします。
（tama） 2021/10/05(火) 16:00
Sub test()
Dim arr
Dim i As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("マスタ")
For i = 1 To 3
With Range(ws.Cells(1, i), ws.Cells(1, i).End(xlDown))
arr = WorksheetFunction.Transpose(Intersect(.Cells, .Offset(1)).Value)
End With
MsgBox ws.Cells(1, i).Value & "用のコピー"
ThisWorkbook.Sheets(arr).Copy
Next i
End Sub
（win95） 2021/10/05(火) 23:22
実際に使用する為に下記のよう自分が使用しているコードと、いただいコードを盛り込んでみました。
Sub test()
Application.ScreenUpdating = False
Dim bookname As String
bookname = Dir(ThisWorkbook.Path & "\全社員データフォルダ\*")’ここに「エクセルファイル１xlsx」(全社員のデータが入ったファイル)を保存しています。
Workbooks.Open ThisWorkbook.Path & "\全社員データフォルダ\" & bookname
Dim arr
Dim i As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("マスタ")’マスタはこのプロシージャを書いている「エクセルファイル5.xlsm」にあります。
For i = 1 To 3
With Range(ws.Cells(1, i), ws.Cells(1, i).End(xlDown))
arr = WorksheetFunction.Transpose(Intersect(.Cells, .Offset(1)).Value)
End With
MsgBox ws.Cells(1, i).Value & "用のコピー"
ThisWorkbook.Sheets(arr).Copy
ActiveWorkbook.SaveAs _
ThisWorkbook.Path & "\分割後フォルダ\" & ws.Cells(1, i).Value "用" & ".xlsx" ’分割後のファイルは、分割後というフォルダを用意しているのでそこに保存させたいです。
Next i
End Sub
以下が新たな問題点です。
エクセルファイル１.xlsxというのは、ファイル名が統一されていないケースが多いので、以下のようなフォルダを用意し、フォルダの中に保存しているデータを使用するような処理にしています。
・「VBA」フォルダの中に、エクセルファイル5.xlsm（マスタがあるファイルのこと）を保存している。
・「VBA」フォルダの中に、「全社員データフォルダ」と「分割後フォルダ」を作成している。
・「全社員データフォルダ」に、「エクセルファイル１.xlsx」（全社員データのこと）を保存している
・「分割後フォルダ」に、分割した(コピーした)ファイルを保存する処理をしたい。
お手数お掛けいたしまして大変申し訳ございません。どうぞよろしくお願いいたします。
（tama） 2021/10/06(水) 16:17
■１
エクセルファイル１.xlsxというのは、ファイル名が統一されていないケースが多い～
単純にデータ元となるブックをユーザーに指定してもらえばよいでしょう。http://officetanaka.net/excel/vba/tips/tips154.htm
■２
＞マスタを登録している「エクセルファイル5.xlsm」に、コピーしたい全社員分のシートが
＞ある場合はうまく動いたのですが、マスタを登録している「エクセルファイル5.xlsm」の
＞データと、全社員分のデータが入った分割前（シートを分ける前）の「エクセルファイル
＞１.xlsx」のデータが別々の為、その辺りを自分で編集してしまうと、うまく動かすことが
＞できませんでした。
残念ながら「2021/10/05(火) 14:57」に提示したコードは研究していただけなかったようですが、【どのブック】に属するシートなのか指定するだけで問題解決しますよ。
Sub サンプル2()
Dim ブックパス As String
Dim srcWB As Workbook
Dim 列 As Long
Dim 最終行 As Long
Stop 'ブレークポイントの代わり
'▼データ元ブックを特定して開く処理
ブックパス = Application.GetOpenFilename("Excel ブック,*.xls?")
If ブックパス = "False" Then
MsgBox "ファイルが指定されなかったので処理中止"
Exit Sub
Else
Set srcWB = Workbooks.Open(ブックパス)
End If
Stop 'ブレークポイントの代わり
'▼自ブックの「マスタ」シートの情報にそって必要なシートをまとめてコピー＆保存する処理
With ThisWorkbook.Worksheets("マスタ")
For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
最終行 = .Cells(.Rows.Count, 列).End(xlUp).Row
'↓で「srcWB」に属するシートがコピー対象であることを指定している
srcWB.Worksheets(WorksheetFunction.Transpose(.Cells(2, 列).Resize(最終行 - 1).Value)).Copy
Workbooks(Workbooks.Count).SaveAs .Cells(1, 列).Value
Workbooks(Workbooks.Count).Close False
Next 列
End With
End Sub
■３
ただ、上記の方法だと、例えば↓のように「srcWB」に該当するシートが無いと対処が出来ません
【マスタ】シートのレイアウト
__A___ __B___ __C___
1 営業部 総務部 人事部
2 田中 高橋 新井
3 鈴木 佐藤 徳川
4 高橋 豊臣
5 織田
この点、１シートずつ処理するアプローチであれば、無いシートはエラーを無視することで対処が可能です。
Sub さんぷる改()
Dim ブックパス As String
Dim srcWB As Workbook
Dim 行 As Long, 列 As Long
Dim dstWB As Workbook
Stop 'ブレークポイントの代わり
'▼データ元ブックを特定して開く処理
ブックパス = Application.GetOpenFilename("Excel ブック,*.xls?")
If ブックパス = "False" Then
MsgBox "ファイルが指定されなかったので処理中止"
Exit Sub
Else
Set srcWB = Workbooks.Open(ブックパス)
End If
With ThisWorkbook.Worksheets("マスタ")
For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
Set dstWB = Workbooks.Add(Template:=xlWBATWorksheet)
'▼１シートずつコピーする処理
On Error Resume Next '←ここから エラーを無視する
For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
srcWB.Worksheets(.Cells(行, 列).Value).Copy after:=dstWB.Worksheets(dstWB.Worksheets.Count)
Next
On Error GoTo 0 '←ここまで エラーを無視する
Application.DisplayAlerts = False
dstWB.Worksheets(1).Delete
dstWB.SaveAs .Cells(1, 列).Value
Application.DisplayAlerts = True
dstWB.Close
Next
End With
End Sub
（もこな２） 2021/10/06(水) 19:31
ﾋｮｺ |ૂ•ᴗ•⸝⸝) …おはようございます。ちょっとだけ、応援に来マスタ
（tama）さん…下記の、ディレクトリ構成図であってますか？ ( ややこしそうですね。)
※ 高橋さんが重複してたので削除しました。また、ちょっと人数が寂しかったので… （もこな２）さんのパクリで、戦国武将さんも追加しました。 ※ イメージと違ってたらゴミ箱ポイしてくださいね。ｲﾗﾈ!! (´ωﾟ｀*)ﾉ⌒ﾟ ﾎﾟｨﾁｮ
【 VBA 】フォルダ | ├ Master.xlsm ( マクロ有 ) | ├「全社員データ」フォルダ | | | └ 全社員データ.xlsx ( 社員リスト ) | | | └├Sheet1 総務部（山下） | ├Sheet2 総務部（佐藤） | ├Sheet3 総務部（豊臣） | ├Sheet4 営業部（田中） | ├Sheet5 営業部（鈴木） | ├Sheet6 営業部（高橋） | ├Sheet7 営業部（織田） | ├Sheet8 人事部（新井） | └Sheet9 人事部（徳川） | └「分割後」フォルダ ( 保存用 ) | └├ 総務部用.xlsx | ├Sheet1（山下） | ├Sheet2（佐藤） | └Sheet3（豊臣） | ├ 営業部用.xlsx | ├Sheet1（田中） | ├Sheet2（鈴木） | ├Sheet3（高橋） | └Sheet4（織田） | └ 人事部用.xlsx ├Sheet1（新井） └Sheet2（徳川）
【 Master.xlsm 】Sheet1 のレイアウト
__A___ __B___ __C___
1 営業部 総務部 人事部
2 田中 山下 新井
3 鈴木 佐藤 徳川
4 高橋 豊臣
5 織田
■今後（やりたいことといたしまして） ＞部署異動があった時にプロシージャを開いて編集しなくても、マスタのリストを編集すれば ＞使えるVBAになるのではないかと思い、これができるコードを教えていただきたいと思っています。（tama）
素晴らしいですね。早く、天下を掴めるよう...応援してますよ。 また、勉強させていただきに来ます。ε＝ε＝ε＝ε＝ε＝(o・・)o ブーン
（あみな） 2021/10/07(木) 10:39
■４
ちなみに、やっぱりダイヤログでユーザーにしてしてもらうのではなく、「全社員データ」フォルダに該当するブックしか置かないことを徹底するなら、発想されたようなことでもよいとは思いますが、それでも↓のように【エクセルブック】であることは指定したほうが良いと思います。
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*")
↓
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*.xls?")
■５
また、「営業部」「総務部」「人事部」のうち、全部は処理する必要がなくて、作業対象の部署だけ指定できるようにしたいというなら、MultiSelectを許可したリストボックスなどを使うと良いと思いますが、ちょっと考えることが増えるのでとりあえず、InputBoxで指定するようにしてみてはどうでしょうか。
このほか、やっぱりシートは一気にコピーしたいということであれば、【作業グループ】の利用を検討してみるのもよいとおもいます。
ただし、作業グループにするにはシートを"選択"する必要があるので、該当のブックがアクティブであることが条件です。（原則ブックを開いたらアクティブになっているで問題ないしょうが、念のため明示的にActivateしたほうがベターだとおもいます）
ということを踏まえると、こんな感じにしてもよいでしょう。
Sub さんぷる3()
Dim srcWB As Workbook
Dim bookname As String
Dim MySTR As String
Dim 部署 As Variant
Dim 列 As Variant
Dim 行 As Long
Dim SH As Worksheet
Dim 選択フラグ As Boolean
Stop 'ブレークポイントの代わり
bookname = Dir(ThisWorkbook.Path & "\全社員データ\*.xls?")
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\全社員データ\" & bookname)
With ThisWorkbook.Worksheets("マスタ")
MySTR = InputBox("処理対象の部署を選択" & vbLf & _
"（複数選択するときは「,」で区切ること)" & vbLf & vbLf & _
"【選択候補】" & vbLf & _
Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Value)), ","))
If MySTR = "" Then
MsgBox "部署が選択されなかったので処理を中止します"
srcWB.Close
Exit Sub
End If
srcWB.Activate
For Each 部署 In Split(MySTR, ",")
列 = Application.Match(部署, .Rows(1), 0)
If IsError(列) Then
MsgBox "「" & 部署 & "」はマスタシートに存在しません" & vbLf & "処理をスキップします"
Else
選択フラグ = False
For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
Set SH = Nothing
On Error Resume Next
Set SH = srcWB.Worksheets(.Cells(行, 列).Value)
On Error GoTo 0
If SH Is Nothing Then
MsgBox 部署 & "の処理でエラー" & vbLf & "「" & .Cells(行, 列).Value & "」シートが存在しません"
Else
srcWB.Activate
SH.Select Not 選択フラグ
選択フラグ = True
End If
Next
If 選択フラグ Then
'↓実際にシートをコピーしているのはこの部分
ActiveWindow.SelectedSheets.Copy
Workbooks(Workbooks.Count).SaveAs ThisWorkbook.Path & "\分割後フォルダ\" & 部署 & "用"
Workbooks(Workbooks.Count).Close False
End If
End If
Next 部署
srcWB.Close False
End With
End Sub
なお、こちらの意図としては完成品のプレゼントではなく、研究材料の提供をしているつもりですので、何も考えずに丸パクリして完成！というのはご遠慮ください。
（必要な部分をご自身のコードに取り入れていったら結果として同じになったのであれば問題ありません）
（もこな２） 2021/10/07(木) 19:54
＞win95様
「ThisWorkbook.Sheets(arr).Copy」で止まってしまうと回答したのですが、その後試行錯誤いたしましたら「ThisWorkbook」を取り除くと処理が実行できました。一から基本を知るべきだと、改めて思いました。早々にご回答いただいたことで、この日の急ぎ対応しなければならない業務が無事完了いたしました。大変ありがとうございました。
＞あみな様
応援してくださりありがとうございます。コメントが大変力になりました。今回はもこな2様の回答により解決の方向です。大変ありがとうございました。
＞もこな2様 この度は、さんぷる1～さんぷる3までお付き合いいただき大変ありがとうございました。
まず、さんぷる1から見直しました。もこな2様から、さんぷる2をいただくことで、なぜさんぷる1で自分がつまずていたのかわかりました。時間がたってしまいすみません。
（実際のマスタは氏名のほかに「_」や「()」などの記号なども入っているのですが、マスタやファイル名の方に問題がありました。）
ご指摘にもありましたが（「なお、こちらの意図としては完成品のプレゼントではなく、研究材料の提供をしているつもりですので、何も考えずに丸パクリして完成！というのはご遠慮ください。」）とありましたように、私が作っているVBAというのは例文と例文のつぎはぎで、その例文というのはいわゆる丸パクリ状態であるゆえに、さんぷる1のつまずきにも自力で解決に至らなかったのだと思います。また、様々な点を見抜かれたうえでさんぷる2.3をお送りいただいたと思うので、大変感謝しております。ありがとうございました。
さんぷる3ですが、このようなことができると、助かる作業が浮かんできました。まだ全てを理解できていない状況ですが、色々とテストして実践的に使えるものにしてみたいと思いました。またもこな2様に教えていただくことがあるかもしれませんが、どうぞよろしくお願いいたします。
皆様ありがとうございました。
（tama） 2021/10/08(金) 15:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.