[[20170701203015]]　『「１つのシートからキー項目ごとに分割したシート』（snow）　ページの最後に飛ぶ

『「１つのシートからキー項目ごとに分割したシートを」[fine]　について』（snow）

投稿
[[20120208211529]] 『１つのシートからキー項目ごとに分割したシートを』（fine）　
について...

■このマクロを使った仕事の業務効率を高めたい者です。
参考にわかる方教えてください。

『１つのシートからキー項目ごとに分割したシートを作る』

 Sheet1に以下のデータがあります。

 社員番号　所属　　氏名　　年齢　入社年月日　・・・・
 0001　　　経理課　山本　　32　　2000/1/1　　・・・・
 0002　　　総務課　鈴木　　40　　1990/4/1　　・・・・
 0003　　　庶務課　山田　　23　　2005/4/1　　・・・・
 0004　　　経理課　中村　　22　　2005/4/1　　・・・・
 0005　　　製造課　本田　　30　　1999/4/1　　・・・・
 0006　　　経理課　青木　　19　　2010/4/1　　・・・・
 0007　　　総務課　中山　　40　　1980/4/1　　・・・・
 0008　　　製造課　田中　　33　　2000/1/1　　・・・・
 0009　　　庶務課　河野　　21　　2008/4/1　　・・・・
このシートを『所属』をキーに別々のシートに分割し、シート名を所属にしたいのですが、
 過去のログ[[20050721182519]]を参考に、所属名でのシート分割ができたのですが、新しく
 生成された所属ごとのシートをみると『Sheet1』で作成したセルの幅と異なり、標準のセル幅に
 なってしまいます。
『Sheet1』を基本フォーマットとして、『所属』をキーに別々のファイルに分割する方法を教えて
 いただけませんか。

この書き込みについて、キー項目がB列ではなくC列になるパターンについても
言及されていますが、同じ所属場のメンバーでこのマクロを共有する場合、
変更方法がわからないひともいるため、インプットボックスなどを出して
キー項目の「列」と「行」を指定（入力）し、マクロを実行するように
できたりしますか？

イメージとして、マクロ実行時に
1)「行」「列」を指定するインプットボックスが出る。
2)上記を入力して「OK」ボタンを押すとマクロが実行され、シートに分割される。
※分割条件
1)指定した行の上の行部分は分割されたシートすべてにヘッダーとして残る。
2)『Sheet1』の書式を引き継ぐ。（印刷範囲等も）

上記のようなものは作れるのでしょうか。
わかる方、教えてください。

よろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 全く違った方法になりますが、項目はどの行にあろうとA列から、ということで。

 Sub test()
    Dim keyCol As String, myRow As Long, x, e
    keyCol = Application.InputBox("項目列の入力", , "C", Type:=2)
    myRow = Application.InputBox("項目行の入力", , 1, Type:=1)
    Application.ScreenUpdating = False
    With Sheets("sheet1")
        With .Range(keyCol & myRow, .Range(keyCol & Rows.Count).End(xlUp))
            x = .Offset(1).Address
            x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & ",,,row(1:" & _
                .Rows.Count & "))," & x & ")=1," & x & "))"), False, 0)
        End With
        For Each e In x
            DeleteSheet e
            .Copy after:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                .Name = e
                With .Range(keyCol & myRow, .Range(keyCol & Rows.Count).End(xlUp))
                    .AutoFilter 1, "<>" & e
                    .Offset(1).EntireRow.Delete
                    .AutoFilter
                End With
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 Private Sub DeleteSheet(ByVal wsName As String)
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(wsName).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
End Sub

（seiya） 2017/07/01(土) 22:03

 修正:

seiyaさん、ありがとうございます。

試してみましたが、「オブジェクトは、このプロパティまたはメソッドをサポートしていません」
と、エラーになります。
なぜでしょう？
（snow） 2017/07/01(土) 23:35

 こちらの設定での動作は確認しています。

 Step debug をして、どこで止まるか確認してください。
（seiya） 2017/07/01(土) 23:43

 おっと、一か所ピリオドが抜けていました Parentの前(変更しておきます)

 >            x = Filter(Parent.Evaluate("transpose(if(countif(offset(" & x & ",,,row(1:" & _
                .Rows.Count & "))," & x & ")=1," & x & "))"), False, 0)

             x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & ",,,row(1:" & _
                .Rows.Count & "))," & x & ")=1," & x & "))"), False, 0)
（seiya） 2017/07/01(土) 23:48

seiyaさん、ありがとうございます。

試してみましたが、思い通りの結果です。
これで、無駄な時間が省けそうです。

大変助かりました。
（snow） 2017/07/02(日) 07:23

コメント返信：

[ 一覧(最新更新順) ]

[[20170701203015]] 『「１つのシートからキー項目ごとに分割したシート』（snow） ページの最後に飛ぶ

[[20170701203015]]　『「１つのシートからキー項目ごとに分割したシート』（snow）　ページの最後に飛ぶ