[[20050721182519]] 『一つのシートから各個人ごとに分割したシートを作』(エクセル初心者) >>BOT

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

 

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

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

シート1

分類 品名    購入日 調理日

野菜 トマト   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

このシートを

       ↓

シート2

分類 品名    購入日 調理日

野菜 トマト   07/01  07/01

野菜 トマト   07/11  07/12

シート3

分類 品名    購入日 調理日

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

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

シート4

分類 品名    購入日 調理日

果物 みかん   07/07  07/07

果物 みかん   07/11  07/11

果物 みかん   07/15  07/18

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

何とか助けてください。


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

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

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

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

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

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


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

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

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

この例を応用し、

(シート1)
分類 品名    購入日 調理日

野菜 トマト   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


(シート2)

分類 品名    購入日 調理日

野菜 トマト   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さん、確かに面白いマクロですね(^^)
 by wkj

コメント返信:

[ 一覧(最新更新順) ]


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