[[20170701203015]] 『「1つのシートからキー項目ごとに分割したシート』(snow) >>BOT

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

 

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

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

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


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

 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


コメント返信:

[ 一覧(最新更新順) ]


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