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

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

 

『1つのシートからキー項目ごとに分割したシートを作る』(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』を基本フォーマットとして、『所属』をキーに別々のファイルに分割する方法を教えて
 いただけませんか。
 
 ちなみに(Mook)さんが作成していたものは以下になります。

 '---------------------------------
 Sub Grouping()
 '---------------------------------
    Dim i%

    Application.ScreenUpdating = False
    With Worksheets(1)
        For i = 2 To .Range("B65535").End(xlUp).Row
            Call AddLine(i, .Cells(i, 2).Value )
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 '---------------------------------
 Sub AddLine(lineNum%, sheetName$)
 '---------------------------------
    Dim lastLine%

    Call checkAndMake(sheetName)
    lastLine = Worksheets(sheetName).Range("B65535").End(xlUp).Row + 1
    Worksheets(1).Rows(lineNum).Copy
    Worksheets(sheetName).Rows(lastLine).Insert Shift:=xlDown
End Sub

 '---------------------------------
 Sub checkAndMake(sheetName$)
 '---------------------------------
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = Worksheets(sheetName)
    If tmpWS Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).name = sheetName
        Worksheets(1).Rows(1).Copy
        Worksheets(sheetName).Rows(1).Insert Shift:=xlDown
    End If
    On Error GoTo 0
End Sub

以上、よろしくお願いいたします。

 [Excel2003/WindowsXP]

 (fine)

 こんなの?

 Option Explicit

 Public Sub Sample()

    'グループの有る列(B列のA列からの列Offset)
    Const clngGroup As Long = 1
    '結果出力の先頭位置
    Const cstrTop As String = "A1"

    Dim i As Long
    Dim lngRows As Long
    Dim lngColumns As Long
    Dim lngTop As Long
    Dim lngCount As Long
    Dim rngList As Range
    Dim rngResult As Range
    Dim rngHeader As Range
    Dim vntGroup As Variant
    Dim vntColumnWidth As Variant
    Dim strProm As String

    'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
    Set rngList = ActiveSheet.Cells(1, "A")

    '画面更新を停止
    Application.ScreenUpdating = False

    With rngList
        '行数の取得
        lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
        '列数の取得
        lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column + 1
        If lngRows <= 0 Then
            strProm = "データが有りません"
            GoTo Wayout
        End If
        '復帰用Keyの出力
        .Offset(1, lngColumns).EntireColumn.Insert
        With .Offset(1, lngColumns)
            .Value = 1
            .Resize(lngRows).DataSeries _
                    Rowcol:=xlColumns, Type:=xlLinear, _
                    Date:=xlDay, Step:=1, Trend:=False
        End With
        'データをB列順のA列順で整列
        .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
                Key1:=.Offset(1, clngGroup), Order1:=xlAscending, _
                Key2:=.Offset(1), Order2:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                Orientation:=xlTopToBottom, SortMethod:=xlStroke
        'A列データを配列に取得
        vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
        '列見出し範囲を取得
        Set rngHeader = .Resize(, lngColumns)
        '列幅を取得
        ReDim vntColumnWidth(lngColumns - 1)
        For i = 0 To lngColumns - 1
            vntColumnWidth(i) = .Offset(, i).EntireColumn.ColumnWidth
        Next i
    End With

    '仮に結果と元表を同じにして置く
    Set rngResult = rngList
    '注目値の位置を記録
    lngTop = 1
    'データ行数のカウント初期値
    lngCount = 1
    For i = 2 To lngRows + 1
        '注目値と現在値が違った場合
        If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
            '出力シートを設定
            GetSheets CStr(vntGroup(lngTop, 1)), cstrTop, rngResult, rngHeader, vntColumnWidth
            'データを転記
            rngList.Offset(lngTop).Resize(lngCount, lngColumns).Copy _
                    Destination:=rngResult.Offset(1)
            '注目値の位置を記録
            lngTop = i
            'データ行数のカウント初期値に
            lngCount = 1
        Else
            'データ行数のカウントを更新
            lngCount = lngCount + 1
        End If
    Next i

    With rngList
        '元データを復帰
        .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
                Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '復帰用Key列を削除
        .Offset(, lngColumns).EntireColumn.Delete
    End With

    strProm = "処理が完了しました"

 Wayout:

    '画面更新を再開
    Application.ScreenUpdating = True

    Set rngList = Nothing
    Set rngResult = Nothing
    Set rngHeader = Nothing

    MsgBox strProm, vbInformation

 End Sub

 Private Sub GetSheets(strName As String, _
                        strTop As String, _
                        rngResult As Range, _
                        rngHeader As Range, _
                        vntWidth As Variant)

    Dim i As Long
    Dim lngRows As Long
    Dim wksMark As Worksheet

    'シートの存在確認
    For Each wksMark In Worksheets
        If StrComp(wksMark.Name, strName, vbTextCompare) = 0 Then
            Exit For
        End If
    Next wksMark
    'もし、シートが無いなら
    If wksMark Is Nothing Then
        'シートを追加して、シート名を設定
        Set wksMark = Worksheets.Add(After:=rngResult.Parent)
        wksMark.Name = strName
    End If

    With wksMark.Range(strTop)
        '行数の取得
        lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
        If lngRows <= 0 Then
            '列幅を設定
            For i = 0 To UBound(vntWidth, 1)
                .Offset(, i).EntireColumn.ColumnWidth = vntWidth(i)
            Next i
            '列見出しを出力
            rngHeader.Copy Destination:=.Offset
        Else
            '前データをクリア
            .Offset(1).Resize(lngRows, rngHeader.Columns.Count).ClearContents
        End If
        '出力位置を設定
        Set rngResult = .Cells(1, 1)
    End With

    Set wksMark = Nothing

 End Sub

 (Bun)


 対象シートが「Sheet1」と言うシート名なら

    'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
    Set rngList = ActiveSheet.Cells(1, "A")

    'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
    Set rngList = Worksheets("Sheet1").Cells(1, "A")

 にして下さい

 (Bun)


Bunさん

 早速の対応ありがとうございます。
 思い通りのシート分割ができました。感謝します。

 もし可能であれば、エクセル未熟者の私に教えていただきたいのですが、
 上記ではキーとなる『所属』がB列となっていますが、これをC列にしたい場合は
 どのように変更すればよろしいのでしょうか。
 また、キーになる列をフォームなどに入力し、資料に応じてキー項目を変更する
 方法などがありましたら、教えていただけると助かります。

 (fine)

 >上記ではキーとなる『所属』がB列となっていますが、これをC列にしたい場合は
 >どのように変更すればよろしいのでしょうか。

 このコード指定にクセは有りますが?
 Keyの変更は簡単に出来る様に成っています

 プロシージャ名の直ぐ下にある

    'グループの有る列(B列のA列からの列Offset)
    Const clngGroup As Long = 1

 の値を代えれば変更出来ます
 Listの先頭列見出しがA1でKeyをC列にするなら

    'グループの有る列(C列のA列からの列Offset)
    Const clngGroup As Long = 2

 とします

 この値は、Listの先頭列見出しの列位置に因って変わってきます
 Upしたコードでは

    'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
    Set rngList = Worksheets("Sheet1").Cells(1, "A")

 と成っていますが、この「.Cells(1, "A")」が基準と成りますので
 このA列を第0列、B列を第1列、C列を第2列と勘定して、この値を使っています

 今回のList先頭はA1としていますが?
 もし、List先頭(「社員番号」の列見出し)がB2なら、「.Cells(2, "B")」とすればListの位置変更も簡単に出来ます
 この時に「所属」をC列とするなら、B列を0列と勘定するので「Const clngGroup As Long = 1」で同じと成ります

 >また、キーになる列をフォームなどに入力し、資料に応じてキー項目を変更する
 >方法などがありましたら、教えていただけると助かります。

 この場合は、現状

    'グループの有る列(B列のA列からの列Offset)
    Const clngGroup As Long = 1

 と定数で定義していますので、此れを

     Dim clngGroup As Long

 と変数で定義して、InputBox等でこのclngGroupに値(列位置)を与えれば善いと思いますが?

 (Bun)


Bunさん

 丁寧な対応ありがとうございました。
 おかげですっきりしました。

 (fine)

 解決済みですから余計なお世話なのですが、
 最新版は、元ファイルの書式を使うようになっています。

[[20111030151618]]『担当別に自動振り分け』(アイル)

 ご参考までに。
 (Mook)

コメント返信:

[ 一覧(最新更新順) ]


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