エクセルの１シートを項目別に別シートへ分ける方法

Question

エクセル2010で１シートのデータを項目別に別シートへ自動的に分割する方法で困っています。
検索するとマクロを使うと書いていますが、マクロはほとんど使ったことが無いのもあって、わかりませんでした。

シート1
A列（日付8ケタ＋商品番号6ケタ）　B列（売上額）
20130515000004　　　　　　　　　　　300
20130515000006　　　　　　　　　　　100
20130518000004　　　　　　　　　　　300
20130519000001　　　　　　　　　　　500
20130519000004　　　　　　　　　　　300
・・・　　　　　　　　　　　　　　　　　　　・・・
をＡ列の日付部分上8ケタを使って日別にシートを分け、
シート名をuriage20130515(uriageと日付8ケタ)という名前にしシート名＋ＣＳＶ形式で保存したいです。

シート２　シート名：uriage20130515
A列　　　　　　　　　B列
20130515000004　300
20130515000006　100

シート３　シート名：uriage20130518
A列　　　　　　　　　B列
20130518000004　300

シート４　シート名：uriage20130519
A列　　　　　　　　　B列
20130519000001　500
20130519000004　300

このように自動で別シートに分割した上で、シート名ＣＳＶ形式で保存まで自動でできるとありがたいです。

自動化できるならシートを分割するマクロ、シート名でＣＳＶ保存するマクロが一つのマクロになっていても、分かれていてもＯＫです。

このようなことはできますか？

よろしくお願いします。

keithin · Accepted Answer

手順：
元データのブックを一度保存して開き直す
ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
　dim myPath as string
　dim myFile as string
　dim h as range
　dim s as string
　dim w as worksheet

mypath = thisworkbook.path & "\"
　on error resume next
　kill mypath & "*.csv"
　application.displayalerts = false
　for each w in worksheets
　　if w.name <> activesheet.name then w.delete
　next
　application.displayalerts = true
　on error goto errhandle

for each h in range("A1:A" & range("A65536").end(xlup).row)
　if isnumeric(h.value) then
　　s = left(h.value, 8)

’ＣＳＶに書き出し
　　open mypath & "uriage" & s & ".csv" for append as #1
　　print #1, h.value & "," & h.offset(0,1).value
　　close #1

’シートに書き出し
　　h.entirerow.copy worksheets(s).range("A65536").end(xlup).offset(1)

end if
　next

for each w in worksheets
　　w.columns("A:B").autofit
　next
　exit sub

errhandle:
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = s
　range("A1:B1") = array("date", "value")
　resume
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＴ＋Ｆ８を押しマクロを実行すると，ＣＳＶを書き出す。

＃「ＣＳＶを書き出す」のが目的で「別シートに振り分ける」こと自体に目的はないと思いましたが，まぁご相談なのでシートに書き出しも追加しました。。。と思って書き足してったら無駄に長いマクロになっちゃいました。あんまりイミなかったです。

kagakusuki · Answer

　uriage20130515等の各日付のシートが、前もって手作業で作成されている場合には、マクロを使わずとも通常のワークシート関数でも日付ごとにデータを分けて抽出する事は可能です。

　まず、uriage20130515シートのA1セルに次の関数を入力して下さい。

=IF(ISNUMBER(REPLACE(CELL("filename",A1),1,FIND("]",CELL("filename",A1),FIND(".xls",CELL("filename",A1)))+LEN("uriage"),)+0),REPLACE(CELL("filename",A1),1,FIND("]",CELL("filename",A1),FIND(".xls",CELL("filename",A1)))+LEN("uriage"),)+0,"")

　次に、uriage20130515シートのA1セルの書式設定の表示形式を[ユーザー定義]の

0000"年"00"月"00"日の売上"

として下さい。
　次に、uriage20130515シートのA3セルに次の関数を入力して下さい。

=IF(ROWS($2:2)>COUNTIF(Sheet1!$A:$A,">="&$A$1*1000000)-COUNTIF(Sheet1!$A:$A,">="&($A$1+1)*1000000),"",SMALL(Sheet1!$A:$A,ROWS($2:2)+COUNTIF(Sheet1!$A:$A,"<"&$A$1*1000000)-COUNTIF(Sheet1!$A:$A,"<1")))

　次に、uriage20130515シートのB3セルに次の関数を入力して下さい。

=IF($A3="","",VLOOKUP($A3,Sheet1!$A:$B,2,FALSE))

　次に、uriage20130515シートのA3～B3の範囲をコピーして、同じ列範囲の4行目以下に貼り付けて下さい。

　次に、uriage20130515シートのコピーシートを作成して、それらのコピーシートのシート名を変更して、他の日付のシートを作成して下さい。
　或いは、既に他の日付のシートが作成済みである場合には、uriage20130515シートのA列～B列の範囲をまとめてコピーして、他の日付のシートのA列～B列に貼り付けて下さい。

　これで、日付ごとにデータを分けて表示させる事が出来ます。
　尚、上記の方法は、Sheet1のA列に入力されている「日付＋商品番号」の中に、同じ値が重複して入力されていない事が前提となっております。
　ですから、もし、「日付＋商品番号」の中に、同じ値が重複して入力されている事もあり得る場合には、補足欄等を使用してその旨を御教え頂けましたら、それに対応する方法を回答させて頂きます。

tom04 · Answer

こんいちは！

CSV形式で保存は手作業でもできると思いますので、
前半の別Sheetに振り分けだけのVBAです。

前提条件
（1）Sheet見出しの一番左が側Sheetに元データがある
（2）1行目は項目行でデータは2行目以降にある

上記前提で標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()   'この行から
    Dim i As Long, k As Long, endRow As Long, wS As Worksheet
    Application.DisplayAlerts = False
    If Worksheets.Count > 1 Then
        For k = Worksheets.Count To 2 Step -1
            Worksheets(k).Delete
        Next k
    End If
    With Worksheets(1)
        endRow = .Cells(Rows.Count, "A").End(xlUp).Row
            .Range("A:A").Insert
            With Range(.Cells(2, "A"), .Cells(endRow, "A"))
                .Formula = "=LEFT(B2,8)"
                .Value = .Value
            End With
        Range(.Cells(1, "A"), .Cells(endRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
        Worksheets.Add after:=Worksheets(1)
        .Range("A:A").Copy Worksheets(2).Range("A1")
        Worksheets(2).Range("A1").Sort key1:=Worksheets(2).Range("A1"), order1:=xlAscending, Header:=xlYes
        For i = 2 To Worksheets(2).Cells(Rows.Count, "A").End(xlUp).Row
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Set wS = Worksheets(Worksheets.Count)
            .Range("A1").AutoFilter field:=1, Criteria1:=Worksheets(2).Cells(i, "A")
            endRow = .Cells(Rows.Count, "A").End(xlUp).Row
                Range(.Cells(1, "B"), .Cells(endRow, "C")).Copy wS.Range("A1")
                wS.Name = "uriage" & Worksheets(2).Cells(i, "A")
                wS.Columns.AutoFit
        Next i
        .AutoFilterMode = False
        .Range("A:A").Delete
    End With
    Worksheets(2).Delete
    Application.DisplayAlerts = True
    MsgBox "処理完了"
End Sub 'この行まで

※　じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

エクセルの１シートを項目別に別シートへ分ける方法

手順：

uriage20130515等の各日付のシートが、前もって手作業で作成されている場合には、マクロを使わずとも通常のワークシート関数でも日付ごとにデータを分けて抽出する事は可能です。

こんいちは！

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

　uriage20130515等の各日付のシートが、前もって手作業で作成されている場合には、マクロを使わずとも通常のワークシート関数でも日付ごとにデータを分けて抽出する事は可能です。