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

質問

エクセル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

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

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

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

よろしくお願いします。

回答No.3

keithin · ベストアンサー

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

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

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

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

お礼

ご回答ありがとうございます。

このマクロで処理が完了しました。

＞「ＣＳＶを書き出す」のが目的で「別シートに振り分ける」こと自体に目的はないと思いましたが

その通りでした。説明がうまくなくすみません。

解決できてよかったです。ありがとうございました。

回答No.2

kagakusuki

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列に入力されている「日付＋商品番号」の中に、同じ値が重複して入力されていない事が前提となっております。
　ですから、もし、「日付＋商品番号」の中に、同じ値が重複して入力されている事もあり得る場合には、補足欄等を使用してその旨を御教え頂けましたら、それに対応する方法を回答させて頂きます。

お礼

ご回答ありがとうございます。

uriage20130515などのシートが無い上に、件数が5万件程度あるデータだったので
この方法はあきらめましたが「マクロでなくても・・・」というやり方もあるのですね。
勉強になりました。

ありがとうございました。

回答No.1

tom04

こんいちは！

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

お礼

ご回答ありがとうございます。

本件はCSVの保存というのが最終目的だったのですが、シートを分けることがいると思い込んでいたのでタイトルから質問内容とふさわしくなかったです。
シートを振り分けるお答えをいただき申し訳ありません。

一番早い回答ありがとうございました。