[[20050721182519]]　『一つのシートから各個人ごとに分割したシートを作』（エクセル初心者）　ページの最後に飛ぶ

『一つのシートから各個人ごとに分割したシートを作る』（エクセル初心者）

一つのシートにデータが以下のように並んでいます。

シート１

分類　品名　　　　購入日　調理日

野菜　トマト　　　07/01 　07/01

野菜　ニンジン　　07/01 　07/01

野菜　ニンジン　　07/02 　07/05

果物　みかん　　　07/07 　07/07

果物　みかん　　　07/11 　07/11

野菜　トマト　　　07/11 　07/12

果物　みかん　　　07/15 　07/18

このシートを

　　　　　　　↓

シート２

分類　品名　　　　購入日　調理日

野菜　トマト　　　07/01 　07/01

野菜　トマト　　　07/11 　07/12

シート３

分類　品名　　　　購入日　調理日

野菜　ニンジン　　07/01 　07/01

野菜　ニンジン　　07/02 　07/05

シート４

分類　品名　　　　購入日　調理日

果物　みかん　　　07/07 　07/07

果物　みかん　　　07/11 　07/11

果物　みかん　　　07/15 　07/18

上記のように、シート１のデータを品名ごとに別々のシートに分割したいのですが、
本当のデータ数は５００件以上、品名も３０件以上なので出来ましたらマクロ等で対応したいのです。何とかできないでしょうか？
また、もう一つ希望としては作成したときに例えばシート２の名前をトマト、
シート３の名前をニンジンなどとできれば最高です。

何とか助けてください。

面白そうなので、つくってみました。
こんなのでどうでしょうか。

 '---------------------------------
 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

（Mook)

mook　さま

お返事遅れまして申し訳ございません。

実際に動かしてみて、思ったとおりの形になりました。

説明不足で不安だったのですが、うれしい限りです。

本当にありがとうございました。
（エクセル初心者）

エクセル初心者で、マクロがまったく分かっていない者です。

この回答すごく参考になりました。

上の例とマクロをコピペして動かすことまではできたのですが、

この例を応用し、

（シート１）
分類　品名　　　　購入日　調理日

野菜　トマト　　　07/01 　07/01

野菜　ニンジン　　07/01 　07/01

野菜　ニンジン　　07/02 　07/05

果物　みかん　　　07/07 　07/07

果物　みかん　　　07/11 　07/11

野菜　トマト　　　07/11 　07/12

果物　みかん　　　07/15 　07/18

↓

（シート２）

分類　品名　　　　購入日　調理日

野菜　トマト　　　07/01 　07/01

野菜　ニンジン　　07/01 　07/01

というように、

購入日でシート分割するには、

上記マクロのどこを変更すればできるようになるのでしょうか。

マクロがまったくわかっていないので、

お分かりになる方がおられましたら教えてください。

よろしくお願いします。

 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, 3).Text) '購入日で分割。但し、TEXTで文字を取り出す
        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

 Mookさん、確かに面白いマクロですね(^^)
 ｂｙ　ｗｋｊ

コメント返信：

[ 一覧(最新更新順) ]

[[20050721182519]] 『一つのシートから各個人ごとに分割したシートを作』（エクセル初心者） ページの最後に飛ぶ

[[20050721182519]]　『一つのシートから各個人ごとに分割したシートを作』（エクセル初心者）　ページの最後に飛ぶ