メモのコツを教えてください！

エクセルのブック分割マクロを教えてください。

解決済

  • 質問者：moooon
  • 質問日時：
  • 回答数：8件

すみません、教えていただきたいのですが。
ひとつのシートの膨大なデータを種類ごとに別ブックの別シートにわけるマクロです。

オリジナルのシートは１枚です。
1行目は項目行で
A:地域名（北米、中南米、欧州、アジア、アフリカ、オセアニア）
B:国名（アメリカ、カナダ、ブラジル等）
C～J：その他各種項目
10000行程度のデータで、ソート済みです。

このシートを、A列の地域別にブック分割をして、それぞれのブックは中に国名別のシートを持ちます。
各シートの配置はオリジナルと同じく１行目に項目、２行以下がデータというならびにしたいのです。

全部で６ブックで、計50シートくらいになります。
各ブック名は地域名（北米等）とし、各シート名は国名となればありがたいです。
なにとぞよろしくお願いします。

通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (8件)

No.3ベストアンサー

  • 回答者： papayuka
  • 回答日時：

BookSeparate だけ実行します。



'******************************************************************
Sub BookSeparate()
Dim myList(), wb As Workbook, tws As Worksheet, i As Integer

On Error Resume Next

Set tws = ThisWorkbook.Worksheets(1)
If Not tws.AutoFilterMode Then
　 tws.Range("A1").CurrentRegion.AutoFilter
End If

Call ListCreate(tws, myList, 1)

For i = 0 To UBound(myList)
　Set wb = Workbooks.Add(xlWBATWorksheet)
　wb.Worksheets(1).Name = myList(i) & " 全て"
　tws.Range("A1").CurrentRegion.AutoFilter _
　　　field:=1, Criteria1:=myList(i)
　tws.Range("A1").CurrentRegion.Copy _
　　　Destination:=wb.Worksheets(1).Range("A1")
　Call SheetSeparate(wb)
　wb.SaveAs Filename:=ThisWorkbook.Path & "\" & myList(i) & ".xls"
Next i

tws.Range("A1").AutoFilter

End Sub

'******************************************************************
Private Sub SheetSeparate(wb As Workbook)
Dim myList(), tws As Worksheet, ws As Worksheet, i As Integer

On Error Resume Next
Set tws = wb.Worksheets(1)

If Not tws.AutoFilterMode Then
　 tws.Range("A1").CurrentRegion.AutoFilter
End If

Call ListCreate(tws, myList, 2)

For i = 0 To UBound(myList)
　　Set ws = wb.Worksheets.Add _
　　　　 (after:=wb.Worksheets(wb.Worksheets.Count))
　　ws.Name = myList(i)
　　tws.Range("A1").CurrentRegion.AutoFilter _
　　　　　　　　　　field:=2, Criteria1:=myList(i)
　　tws.Range("A1").CurrentRegion.Copy _
　　　　　　　　　　Destination:=ws.Range("A1")
　　Application.CutCopyMode = False
Next i

tws.Range("A1").AutoFilter

End Sub

'******************************************************************
Private Sub ListCreate(ws As Worksheet, rList, myCol As Integer)
Dim myLow As Long, cnt As Long

myLow = 2: cnt = 0

Do While ws.Cells(myLow, myCol).Value <> ""
　 If ws.Cells(myLow, myCol).Value <> _
　　　ws.Cells(myLow, myCol).Offset(-1, 0).Value Then
　　　ReDim Preserve rList(cnt)
　　　rList(cnt) = ws.Cells(myLow, myCol).Value
　　　cnt = cnt + 1
　 End If
　 myLow = myLow + 1
Loop

End Sub
    • good
    • 1
    • 件
通報する
この回答へのお礼

ありがとうございます。
試しましたところ正しく作動しました。
ただ、残念ながらコードがわかりません。
勝手をいいますが、解説を付けていただけると幸いです。

通報する
お礼日時：2006/06/09 23:56

No.8

  • 回答者： toshi_2000
  • 回答日時：

No.2です。


お礼の１のみ対応しています。
２，３は手作業でできるので未対応です。

MYBOOK = ActiveWorkbook.Name
行 = 2
Do While Cells(行, 1) <> ""
If Cells(行, 1) <> Cells(行 - 1, 1) Then
地域名 = Cells(行, 1)
国名 = Cells(行, 2)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=地域名

Worksheets.Add
Worksheets(Sheets.Count).Name = 国名
Workbooks(MYBOOK).Activate
Range(Cells(行, 1), Cells(行, 10)).Copy
Windows(地域名 & ".xls").Activate
Worksheets(Sheets.Count).Select
Range("A1").Select
ActiveSheet.Paste

Else
国名 = Cells(行, 2)
If Cells(行, 2) <> Cells(行 - 1, 2) Then
Windows(地域名 & ".xls").Activate
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Sheets.Count).Name = 国名
End If
Workbooks(MYBOOK).Activate
Range(Cells(行, 1), Cells(行, 10)).Copy
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
Workbooks(MYBOOK).Activate
If Cells(行, 2) <> Cells(行 - 1, 2) Then
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
Range("A1").Select
書込行 = 1
Else
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
書込行 = 書込行 + 1
Range(Cells(書込行, 1), Cells(書込行, 1)).Select
End If
ActiveSheet.Paste

End If
Workbooks(MYBOOK).Activate
行 = 行 + 1
Loop
    • good
    • 1
    • 件
通報する
この回答へのお礼

ありがとうございます。

通報する
お礼日時：2006/06/24 16:43

No.7

  • 回答者： imogasi
  • 回答日時：

回答は、既に出ているようですが


（１）手作業かＶＢ（マクロの記録が応用できる）で
Ａ列（第１キー）、Ｂ列（第２キー）でソートします。
（２）Ａ列＆Ｂ列の結合文字列を作り、直前まと変わってないか判別します同じ国名がなければＢ列ソートだけでも良いかも。
（３）変わっていなければ特定のシートに今の行データを記録。
（４）変わった場合ば、特定のシートをブック名＋指定シート名で
保存する。（マクロの記録が応用できると思う）
特定のシートのデータをクリア
（５）現在の行で（３）を行う
（６）最終行まで繰り返す。
　　　最終行で（４）うお行うのを忘れずに。
このロジックが、お勧めです。
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
mk = sh1.Cells(2, "A") & sh1.Cells(2, "B")
k = 2
d = sh1.Range("A65536").End(xlUp).Row
For i = 2 To d
'比較処理
gk = sh1.Cells(i, "A") & sh1.Cells(i, "B")
'---
If gk <> mk Then
'変わった場合
'ブックへの書き出し（略）
sh2.Cells.Clear
k = 2
End If
'変わらない場合と変わった場合とも
'---
For j = 1 To 5
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j
k = k + 1
Next i
'最終行書き出し処理
For j = 1 To 5
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j
'ブックへの書き出し（略）
End Sub
（ただし上記のままでは(略）の部分を入れないと役に立ちません。）
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。

通報する
お礼日時：2006/06/24 16:43

No.6

  • 回答者： papayuka
  • 回答日時：

#3です。


私も独学で学んだくちなので間違いがあるかも知れませんが、、、

VBAヘルプで Subステートメントを引くと、引数は ByRef（参照渡し）が規定値と書いてあります。
下記を実行すると Sub A の変数 i が参照渡しで Sub B1 に渡された事で 10加算されるのが解ります。

Sub A()
Dim i As Integer
　　i = 0
　　Call B1(i)　' i を渡す
　　MsgBox "参照渡しだと加算されて i は" & Str(i)

　　Call B2(i)　' i を渡す
　　MsgBox "値渡しだと加算されず i は" & Str(i) & "のまま"
End Sub

Private Sub B1(ByRef cnt As Integer)
　　cnt = cnt + 10
End Sub

Private Sub B2(ByVal cnt As Integer)
　　cnt = cnt + 10
End Sub

つまり、呼出し先の処理で呼出し元の変数を操作しているって事です。

ListCreate(ws As Worksheet, rList, myCol As Integer)
は「処理対象のワークシート」と「呼出し元で用意した器（の参照）」と「必要な列番」を受取って、それを使って処理をしています。
A列でブック分けをするリスト作りも、B列でシート分けをするリスト作りも、どちらも処理は殆ど同じで、違いは「処理対象ワークシート」と「必要な列番」だけですので。
（どちらかと言うと Function でやるべきものかも知れませんけど、、、）
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。

通報する
お礼日時：2006/06/24 16:42

No.5

  • 回答者： papayuka
  • 回答日時：

#3です。



オートフィルを掛けて　→　オートフィルタを掛けて

ですね。
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。

通報する
お礼日時：2006/06/24 16:41

No.4

  • 回答者： papayuka
  • 回答日時：

#3です。


VBAの質問に回答されてるので、まったく解らない訳では無いですよね？
具体的にどのあたりが不明でしょうか？

流れとしては

A列でソートが掛かっている前提なので、A列の値が変化したら配列Aに入れてやります。
その配列Aでループしながらオートフィルを掛けてブックを作ります。
作ったブック内のB列で配列Bを作ります。
その配列Bでループしながらオートフィルを掛けてシートを作ります。

って事を配列A分繰り返してます。
配列を作るロジックはまったく同じなのでサブルーチンにして引数で列を指定してます。（ListCreate）
ブック展開するループで、シート展開ループを入れると解りづらいのでシート展開はサブルーチンにしてます。（SheetSeparate）

ExcelとVBE画面を並べて表示して、「デバック」－「ステップイン」からステップ実行して F8 キーで追ってみたら何となく解るかも。
サブルーチンのループはEnd Subにカーソルをあてて、「カーソル行前まで実行」で飛ばせます。

ちなみにコピーブックを閉じたいなら、

wb.SaveAs Filename:=ThisWorkbook.Path & "\" & myList(i) & ".xls"
の下に wb.close を入れれば良いハズです。
    • good
    • 0
    • 件
通報する
この回答へのお礼

ご丁寧にありがとうございます。

Call ListCreate(tws, myList, 1)のような引数をつけたサブルーチン？の呼び出しがよく理解できないのです。とくにmyListが配列であろうとは想像できますが具体的にどんな仕組みなのか・・・。

不勉強ですね。すみません。

通報する
お礼日時：2006/06/10 01:43

No.2

  • 回答者： toshi_2000
  • 回答日時：

以下の通り（サンプル数が少ないので十分検証できてません）


MYBOOK = ActiveWorkbook.Name
行 = 2
Do While Cells(行, 1) <> ""
If Cells(行, 1) <> Cells(行 - 1, 1) Then
地域名 = Cells(行, 1)
国名 = Cells(行, 2)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=地域名

Worksheets.Add
Worksheets(Sheets.Count).Name = 国名
Workbooks(MYBOOK).Activate
Range(Cells(行, 1), Cells(行, 10)).Copy
Windows(地域名 & ".xls").Activate
Worksheets(Sheets.Count).Select
Range("A1").Select
ActiveSheet.Paste

Else
国名 = Cells(行, 2)
If Cells(行, 2) <> Cells(行 - 1, 2) Then
Windows(地域名 & ".xls").Activate
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Sheets.Count).Name = 国名
End If
Workbooks(MYBOOK).Activate
Range(Cells(行, 1), Cells(行, 10)).Copy
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
Workbooks(MYBOOK).Activate
If Cells(行, 2) <> Cells(行 - 1, 2) Then
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
Range("A1").Select
Else
Windows(地域名 & ".xls").Activate
Worksheets(国名).Select
Range(Cells(Cells(65536).End(xlUp).Row + 1, 1), Cells(Cells(65536).End(xlUp).Row + 1, 1)).Select
End If
ActiveSheet.Paste

End If
Workbooks(MYBOOK).Activate
行 = 行 + 1
Loop
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
ためしたところ、以下の不具合があります。

1.各シートに転記された国別データが全シートとも1番目と最後の2つしかありませんでした。
2.全ブックが開いたままでした。
3.全ブックとも最初に空白なシートがありました。

修正できるものであればよろしくお願いします。
すみません。

通報する
お礼日時：2006/06/09 23:18

No.1

  • 回答者： misatoanna
  • 回答日時：

回答ではありませんが、


> 10000行程度のデータで、ソート済みです。
> 全部で６ブックで、計50シートくらいになります。
例えばアジア地域の場合、Ａ列のすべてのセルに「アジア」という文字列が、
日本の場合、Ｂ列のすべてのセルに「日本」という文字列が、
それぞれ入っているのですか？

この回答への補足

はい、データがあるすべての行のA列のセルに地域名が入っています。
同様にB列には国名が入っています。途中に空白はありません。
よろしくお願いします。

補足日時：2006/06/09 18:56
通報する
    • good
    • 0
    • 件
通報する

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

ページトップページトップ

おすすめ情報

Q質問する（無料）

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

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

おすすめ情報