[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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)
早速の対応ありがとうございます。 思い通りのシート分割ができました。感謝します。
もし可能であれば、エクセル未熟者の私に教えていただきたいのですが、 上記ではキーとなる『所属』が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)
丁寧な対応ありがとうございました。 おかげですっきりしました。
(fine)
解決済みですから余計なお世話なのですが、 最新版は、元ファイルの書式を使うようになっています。
[[20111030151618]]『担当別に自動振り分け』(アイル)
ご参考までに。 (Mook)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.