[[20210920170325]] 『1つのエクセルシート内にある部署を新たなフォル』(サン) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『1つのエクセルシート内にある部署を新たなフォルダに部署名ごとのbookをつくり、分割したい』(サン)

エクセルVBA初心者です。
課題として、

  A    B   C D       A
1 aさん 営業部 男 住所1  1 ボタン
2 bさん 人事部 女 住所2
3 cさん 営業部 男 住所3
4 dさん 技術部 男 住所4
5 eさん 経理部 男 住所4

シート データ集約       シート データ分割実行

実施したいこと
?@シート(データ集約)にあるデータを
?Aシート(データ分割実行)内にあるボタンをクリックする。
?Bボタンをクリックすると、新しくフォルダをつくる
?Cフォルダ内に、営業部、人事部、技術部、技術部、その他部署のエクセルbookが出来ている
?D営業部のbookを開くと
1 aさん 営業部 男 住所1  
2 cさん 営業部 男 住所3
が表示されている。
※、人事部、技術部、技術部でも同様です。

VBAプログラムとして
ボタン_Click()
からの書き方がわかりません
お知恵をお借りできないでしょうか。

< 使用 Excel:Excel2016、使用 OS:Windows10 >


Dir
MkDir
Workbooks.Add
SaveCopyAs
ループ処理
変数
連想配列
等々が必要になるかと、各、ステートメント、処理
など、読本、ネット検索等で予習しておくと即
役だつやもしれません。←多分。。。(*^ ^*)v
m(_ _)m
(隠居Z) 2021/09/20(月) 17:28

 こんばんわ ^^
↑ とりとめもない。。。乱雑な、提案で、済みません。
誰だったか忘れましたが、どなたか様の様に、少し取り纏めてみました
足元にも及びませんが。。。A^^;
1.連想配列、作成
2.マクロブックを変数に格納
3.2.を使いブック、シートを明示的に指定して、範囲を
  レンジ[フイルタ詳細用]、と、配列[連想配列で所属の一意なキー作成用]に格納
4.キー作成後、配列に格納
5.新規フォルダを、同フォルダ内に無ければ、作成
6.新規ブック作成後、仮名を付けて、作成するブックの形式で一応保存する
7.4.の配列[各所属名]を使いループし、フイルタ詳細で所属名毎に抽出して
  体裁を整え、名前を付け、保存、
8.シートの初期化
9.7〜8を最後の所属名まで繰り返す
10.仮名で作成したブックを閉め、削除
11.後始末。
おしまい。(*^ ^*)。。。-⊆^U)┬┬~ 。。
m(_ _)m
(隠居Z) 2021/09/20(月) 21:42

他のコードを組み合わせて、つくってみたのですが、
A列だけ、分割した際に部署で切れない状況です。

どうしたらいいのでしょうか?

Public myDic As Object
Sub SplitBook()

'分割したファイルを出力するフォルダを設定
splitToPath = "C:\Users\ユーザー\Desktop\ファイル分割用\"
splitToName = "部.xlsm" '分割ファイルの名前を設定
targetSheet = "データ" '分割したいデータがあるシート名を指定
dataRow = 2 '分割したいデータの始点行を指定 行横
dataCol = 2 '分割したいデータの開始列を指定 列縦
TargetCol = 2 '分割ルールの列を指定。ここでは分けたいため2列(B列)目を指定

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook

masterBook = wb.Path & "\" & wb.Name

'分割数及び分割名を算出
Call GetSplitNames(wb, targetSheet, dataRow, dataCol, TargetCol)

For Each Item In myDic

    'ファイルコピー
    objFSO.copyFile masterBook, splitToPath & Item & splitToName

    'コピーしたファイル展開
    Workbooks.Open splitToPath & Item & splitToName

    '不要行削除
    Call CellsDeleteFast(dataRow, dataCol, Item)

    'ファイルを上書き保存して閉じる
    ActiveWorkbook.Close SaveChanges:=True
Next

End Sub
Sub GetSplitNames(wb, targetSheet, dataRow, dataCol, TargetCol)

Dim ws As Worksheet
Dim lastRow As Long
Dim varData As Variant

Set ws = wb.Worksheets(targetSheet)
Set myDic = CreateObject("Scripting.Dictionary")

lastRow = ws.Cells(Rows.Count, dataCol).End(xlUp).Row
varData = ws.Range(ws.Cells(dataRow + 1, TargetCol), ws.Cells(lastRow, TargetCol))

For Each Item In varData

    If Not Item = Empty Then
        If Not myDic.Exists(Item) Then
            myDic.Add Item, Null
        End If
    End If
Next

End Sub
Sub CellsDeleteFast(dataRow, dataCol, targetNum)

Dim ListLastRow As Long
Dim DeleteCells As Range
Dim ws As Worksheet

'対象シートは適時変更
Set ws = ActiveSheet
'A列を見て最終行を取得 リストがA列以外なら要変更
ListLastRow = ws.Cells(Rows.Count, dataCol).End(xlUp).Row
ListLastCol = ws.Cells(dataRow, dataCol).End(xlToRight).Column

'1行目は見出しとみなし、2行目から探査
For i = dataRow + 0 To ListLastRow

    'Rangeに削除対象行を格納 ※今回は指定クラス名以外。
    If ws.Cells(i, dataCol) <> targetNum Then
        '初回のみ
        If DeleteCells Is Nothing Then
            Set DeleteCells = ws.Range(ws.Cells(i, dataCol), ws.Cells(i, ListLastCol))
        '2回目以降は追加
        Else
            Set DeleteCells = Union(DeleteCells, ws.Range(ws.Cells(i, dataCol), ws.Cells(i, ListLastCol)))
        End If
    End If
Next

'削除対象行が1つでもあれば行削除を実施
If Not DeleteCells Is Nothing Then DeleteCells.Delete (xlShiftUp)

End Sub

(サン) 2021/09/20(月) 22:05


 こういうことがしたいのかと思っていたのですが、
 ちょっと思ってたのと違うのかも・・・
 その場合は無視して下さい。
 ※データ集約シートが存在しているブックを複製して、そちらで試してください。
 ※そのブックと同じフォルダに部署フォルダが作成されます。

 Sub test()
    Dim Dic As Object, FSO As Object
    Dim ws As Worksheet, ts As Worksheet
    Dim i As Long
    Dim arr() As Variant
    Dim fName As String

    Set ws = Worksheets("データ集約")
    Set Dic = CreateObject("Scripting.Dictionary")
    Set FSO = CreateObject("Scripting.FileSystemObject")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
        With ws.Cells(i, 2)
            If Not Dic.Exists(.Value) Then Dic.Add .Value, i
        End With
    Next i
    arr = Dic.keys
    For i = LBound(arr) To UBound(arr)
        fName = FSO.BuildPath(ThisWorkbook.Path, arr(i))
        If Not FSO.FolderExists(fName) Then FSO.CreateFolder fName
        Set ts = Worksheets.Add
        ts.Name = arr(i)
        With ws.Cells(1, 1)
            .AutoFilter Field:=2, Criteria1:=arr(i)
            .CurrentRegion.Copy ts.Cells(1, 1)
        End With
        ws.AutoFilterMode = False
        ts.Copy
        With ActiveWorkbook
            .SaveAs FSO.BuildPath(fName, arr(i) & ".xlsx")
            .Close
        End With
        ts.Delete
    Next i

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 End Sub
(#) 2021/09/20(月) 22:32

 こんばんわ ^^
わたしも、作ってみましたので、参加させてくださいませ。
アドバンスドフイルター版!。。。^^;m(_ _)m
情報シート名は データです。マクロブックと同フォルダ、配下に
NewFolderD という、フォルダが作成され、こちらに所属毎のブッ
クが、無ければ作成、有れば上書きされますです。
マクロブック名は、IDに合わせるか、お試しのブック名にIDを書き換え
るか、どちらかで対応してくださいね。
外していましたら、お許しを。ゴミ箱ポイお願いいたします。A^^;
Option Explicit
Sub OneInstanceMain()
    Const zProgramID  As String = "IJ00353.xlsm"
    Dim zTb           As Workbook
    Dim wb            As Workbook
    Dim i             As Long
    Dim fD            As String
    Dim v()           As Variant
    Dim zD            As Object
    Dim mKey()        As Variant
    Dim r             As Range
    Dim t             As Double
    t = Timer
    Set zD = CreateObject("Scripting.Dictionary")
    Set zTb = Workbooks(zProgramID)
    fD = zTb.Path & "\"
    With zTb.Worksheets("データ")
        Set r = .Cells(1).CurrentRegion
        v = r.Value
    End With
    For i = 2 To UBound(v, 1)
        zD(v(i, 2)) = Empty
    Next
    mKey = zD.keys
    If Dir(fD & "NewFolderD", vbDirectory) = "" Then
        MkDir fD & "NewFolderD"
    End If
    fD = fD & "NewFolderD\"
    Set wb = Workbooks.Add
    wb.SaveAs fD & "TMP.xlsx", 51
    For i = 0 To UBound(mKey)
        With wb.Worksheets(1)
            .UsedRange.Clear
            .Range("XFD1:XFD2").NumberFormat = "@"
            .Range("XFD1") = "所 属"
            .Range("XFD2") = "=" & mKey(i)
            r.AdvancedFilter xlFilterCopy, .Range("XFD1:XFD2"), .Cells(1)
            .UsedRange.Columns.AutoFit
            .Range("XFD1:XFD2").Clear
        End With
        wb.SaveCopyAs fD & mKey(i) & ".xlsx"
    Next
    wb.Close False
    If Dir(fD & "TMP.xlsx") <> "" Then
        Kill fD & "\TMP.xlsx"
    End If
    zD.RemoveAll
    Erase v, mKey
    MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
(隠居Z) 2021/09/20(月) 22:44

既に解決方法も示されているようですが、何点か。

■1
質問とは関係ありませんが、この掲示板では丸付き数字などの環境依存文字を使うと、文字化けすることがあるので避けたほうがよいとおもいます。

■2
提示の例を見ると1行目からデータが始まっているように見えますが本当ですか?

 特に、コードを見ると↓のようなコメントがあるのが気になります。
 '1行目は見出しとみなし、2行目から探査

もしも、項目行があるのであれば既に紹介のあったフィルタオプションやオートフィルタによる抽出も有効に思います。

■3
提示のあったコードはざっとしか読んでませんが、丸ごとコピーしておきいらないファイルを削除するという発想ですね。
それもよいでしょうが、以下のようなアプローチでも解決可能と思われます。

 (1)保存用のフォルダを作成する
 (2)データ集約シートのB列から、重複しないリストを得る
 (3)リストに沿ってB1〜B列最終行までを巡回して該当する【セル】をピックアップする
 (4)ピックアップした【セル】を含む【行】をコピーする
 (5)新規ブックに貼付する
 (6)(5)のブックをリストの名前で保存する

この場合、(4)〜(6)の処理は【マクロの記録】でたたき台となるコードが得られます。

■4
以上を踏まえると、以下のようなアプローチでも解決できるとおもいます。
興味があれば【ステップ実行】して研究してみてください。

    Sub 興味があれば研究してみてください()
        Dim フォルダパス As String
        Dim 最終行 As Long
        Dim myDic As Object
        Dim i As Long
        Dim 部署 As Variant
        Dim MyRNG As Range

        Stop 'ブレークポイントの代わり

        フォルダパス = ThisWorkbook.Path & "\" & Format(Now, "YYYYMMDD_hhmmss")
        Set myDic = CreateObject("Scripting.Dictionary")

        '▼(1)フォルダを作成する
        MkDir フォルダパス

        With Worksheets("データ集約")
            最終行 = .Cells(.Rows.Count, "B").End(xlUp).Row

            '▼(2)重複しないリストを得る
            On Error Resume Next
            For i = 1 To 最終行
                myDic.Add .Cells(i, "B").Value, ""
            Next i
            On Error GoTo 0

            '▼(3)リストに沿って該当するセルをピックアップする
            For Each 部署 In myDic.keys
                Set MyRNG = Nothing
                For i = 1 To 最終行
                    If .Cells(i, "B").Value = 部署 Then
                        If MyRNG Is Nothing Then
                            Set MyRNG = .Cells(i, "B")
                        Else
                            Set MyRNG = Union(MyRNG, .Cells(i, "B"))
                        End If
                    End If
                Next i

                '▼(4)(5)ピックアップしたセルを含む行を新規ブックへコピーする
                MyRNG.EntireRow.Copy Workbooks.Add.Worksheets(1).Range("A1")

                '▼(6)リストの名前で保存して閉じる
                With Workbooks(Workbooks.Count)
                    .SaveAs フォルダパス & "\" & 部署
                    .Close False
                End With

            Next
        End With
    End Sub

(もこな2 ) 2021/09/21(火) 03:42



メモしていた内容までうっかり投稿していたので、修正しました。

(もこな2) 2021/09/21(火) 08:33


お返事が遅くなり。申し訳ありません。
皆様ありがとうございます。

一旦、課題はクリアしたものの拡大版として、再度検討するようにと言われ
このコードのままで最低限、修正したいと思っています。

今回のコードでは、
改修したいこと
1A列に文字が入っていると、B列のキーワードで区切ってもの
 A列の文字が霧分けされないので、どうにかしたいです。

2今回は、B列でしたが、その他の列を選択しても、動作するようにしたい。
 現状、B列以外はうまく切り分けできないので、どうにかしたい

   A    B    C       D     E     F   
1 文字1 文字2 文字3 文字4 文字5  文字6
2 A    1    あ   a      E2      F4
3 B    2    い   c      E4      F2
4 A    1    う   c      E2      F3
5 C    3    あ   b      E4      F3     
6 B    2    い   c      E2      F2
7 A    1    う   a      E1      F4
8 D    2    あ   a      E3      F3

変数で、任意の列に指定できるようにしておいたのですが、
どこを直したらいいのでしょうか。

dataRow = 2 '分割したいデータの始点行を指定 行横
dataCol = 2 '分割したいデータの開始列を指定 列縦
TargetCol = 2

Public myDic As Object
Sub SplitBook()
'分割したファイルを出力するフォルダを設定
splitToPath = "C:\Users\ユーザー\Desktop\ファイル分割用\"
splitToName = "部.xlsm" '分割ファイルの名前を設定
targetSheet = "データ" '分割したいデータがあるシート名を指定
dataRow = 2 '分割したいデータの始点行を指定 行横
dataCol = 2 '分割したいデータの開始列を指定 列縦
TargetCol = 2 '分割ルールの列を指定。ここでは分けたいため2列(B列)目を指定
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
masterBook = wb.Path & "\" & wb.Name
'分割数及び分割名を算出
Call GetSplitNames(wb, targetSheet, dataRow, dataCol, TargetCol)
For Each Item In myDic

    'ファイルコピー
    objFSO.copyFile masterBook, splitToPath & Item & splitToName
    'コピーしたファイル展開
    Workbooks.Open splitToPath & Item & splitToName
    '不要行削除
    Call CellsDeleteFast(dataRow, dataCol, Item)
    'ファイルを上書き保存して閉じる
    ActiveWorkbook.Close SaveChanges:=True
Next
End Sub
Sub GetSplitNames(wb, targetSheet, dataRow, dataCol, TargetCol)
Dim ws As Worksheet
Dim lastRow As Long
Dim varData As Variant
Set ws = wb.Worksheets(targetSheet)
Set myDic = CreateObject("Scripting.Dictionary")
lastRow = ws.Cells(Rows.Count, dataCol).End(xlUp).Row
varData = ws.Range(ws.Cells(dataRow + 1, TargetCol), ws.Cells(lastRow, TargetCol))
For Each Item In varData
    If Not Item = Empty Then
        If Not myDic.Exists(Item) Then
            myDic.Add Item, Null
        End If
    End If
Next
End Sub
Sub CellsDeleteFast(dataRow, dataCol, targetNum)
Dim ListLastRow As Long
Dim DeleteCells As Range
Dim ws As Worksheet
'対象シートは適時変更
Set ws = ActiveSheet
'A列を見て最終行を取得 リストがA列以外なら要変更
ListLastRow = ws.Cells(Rows.Count, dataCol).End(xlUp).Row
ListLastCol = ws.Cells(dataRow, dataCol).End(xlToRight).Column
'1行目は見出しとみなし、2行目から探査
For i = dataRow + 0 To ListLastRow
    'Rangeに削除対象行を格納 ※今回は指定クラス名以外。
    If ws.Cells(i, dataCol) <> targetNum Then
        '初回のみ
        If DeleteCells Is Nothing Then
            Set DeleteCells = ws.Range(ws.Cells(i, dataCol), ws.Cells(i, ListLastCol))
        '2回目以降は追加
        Else
            Set DeleteCells = Union(DeleteCells, ws.Range(ws.Cells(i, dataCol), ws.Cells(i, ListLastCol)))
        End If
    End If
Next
'削除対象行が1つでもあれば行削除を実施
If Not DeleteCells Is Nothing Then DeleteCells.Delete (xlShiftUp)
End Sub
(サン) 2021/09/26(日) 12:50


 初回の話は、以下のシートを前提として、
 B列の"部"毎に、ファイルを分割するというもののようでした。

 |    A      B       C    D                   A
 | 1 aさん  営業部  男  住所1           1  ボタン
 | 2 bさん  人事部  女  住所2
 | 3 cさん  営業部  男  住所3
 | 4 dさん  技術部  男  住所4
 | 5 eさん  経理部  男  住所4

 今回の話(下記)は、上記とは別の話ですか?

 |     A      B      C          D       E        F     
 | 1  文字1  文字2  文字3  文字4  文字5  文字6
 | 2  A        1        あ      a      E2      F4
 | 3  B        2        い      c      E4      F2
 | 4  A        1        う      c      E2      F3
 | 5  C        3        あ      b      E4      F3     
 | 6  B        2        い      c      E2      F2
 | 7  A        1        う      a      E1      F4
 | 8  D        2        あ      a      E3      F3

 | 改修したいこと
 | 1 A列に文字が入っていると、B列のキーワードで区切ってもの
 |    A列の文字が霧分けされないので、どうにかしたいです。
 | 2 今回は、B列でしたが、その他の列を選択しても、動作するようにしたい。
 |    現状、B列以外はうまく切り分けできないので、どうにかしたい

 | A列に文字が入っていると、A列の文字が切り分けされないので、
 というところが意味が分かりません。

 B列が2のデータには、A列がBのものと、D列のものがあるので、
 これらは別のブックにしたいということですか?
 それなら、
 B列の値 & "_" &  A列の値 といったものをキーにして、
 それぞれブックに分離すればよいのでは?

 | 2 今回は、B列でしたが、その他の列を選択しても、動作するようにしたい。
 |    現状、B列以外はうまく切り分けできないので、どうにかしたい
 については、
 単に、TargetCol 変数を2ではなく、別のものに指定すればよいのではないんですか?

(γ) 2021/09/26(日) 18:34


よく見ていませんが、ぱっとみで。

>このコードのままで最低限、修正したい

ならば、下記のように、削除する範囲を行全体にしてはどうでしょうか。
2ヶ所あります。

 >ws.Range(ws.Cells(i, dataCol), ws.Cells(i, ListLastCol))
    ↓
   ws.Rows(i)

(マナ) 2021/09/26(日) 18:42


>A列の文字が霧分けされないので、どうにかしたいです。

A列のデータが削除されないで残ってしまうので
何とかしたいという質問と考えました。

(マナ) 2021/09/26(日) 18:48


ああ、そうなんですね。
仕様の一部変更とかじゃなかったのですね。
想定は、こうなるべきだが、実はこんなことになってしまう、
と説明してもらうと分かり易かった。
なかなか難しいものですね。失礼しました。
(γ) 2021/09/26(日) 19:40

質問者さんへの提言です。

(1)モジュールの最初に
Option Explicit
を入れて、変数は必ず宣言するようにしたほうがよいと思います。
http://officetanaka.net/excel/vba/beginner/06.htm
を参照すれば、自動的にそれが挿入される方法が書かれています。
是非、そのようにすることを推奨します。

(2)また、インデントももう少し丁寧につけたほうがよいと思います。

(3)内容的には、皆さんから提案があったように、
まるまるコピーしてから不要なところを削除する方法は余りよくありません。
削除は結構負荷がかかる操作なので、できるだけ避けたほうがよいと思います。
必要なものだけを抽出する方式(例えば、オートフィルタやフィルタオプション)を推奨します。

ちなみに、私が仕様変更・追加と考えた理由がわかりました。
>一旦、課題はクリアしたものの拡大版として、再度検討するようにと言われ
>このコードのままで最低限、修正したいと思っています。
と書いてあるんですよ。

投稿の最初からA列が残る問題があったんですね。
どこが課題はクリアしたのか、疑問。

(γ) 2021/09/26(日) 22:28


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.