
すみません、教えていただきたいのですが。
ひとつのシートの膨大なデータを種類ごとに別ブックの別シートにわけるマクロです。
オリジナルのシートは1枚です。
1行目は項目行で
A:地域名(北米、中南米、欧州、アジア、アフリカ、オセアニア)
B:国名(アメリカ、カナダ、ブラジル等)
C~J:その他各種項目
10000行程度のデータで、ソート済みです。
このシートを、A列の地域別にブック分割をして、それぞれのブックは中に国名別のシートを持ちます。
各シートの配置はオリジナルと同じく1行目に項目、2行以下がデータというならびにしたいのです。
全部で6ブックで、計50シートくらいになります。
各ブック名は地域名(北米等)とし、各シート名は国名となればありがたいです。
なにとぞよろしくお願いします。
No.3ベストアンサー
- 回答日時:
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
ありがとうございます。
試しましたところ正しく作動しました。
ただ、残念ながらコードがわかりません。
勝手をいいますが、解説を付けていただけると幸いです。
No.8
- 回答日時:
No.2です。
お礼の1のみ対応しています。
2,3は手作業でできるので未対応です。
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
No.7
- 回答日時:
回答は、既に出ているようですが
(1)手作業かVB(マクロの記録が応用できる)で
A列(第1キー)、B列(第2キー)でソートします。
(2)A列&B列の結合文字列を作り、直前まと変わってないか判別します同じ国名がなければB列ソートだけでも良いかも。
(3)変わっていなければ特定のシートに今の行データを記録。
(4)変わった場合ば、特定のシートをブック名+指定シート名で
保存する。(マクロの記録が応用できると思う)
特定のシートのデータをクリア
(5)現在の行で(3)を行う
(6)最終行まで繰り返す。
最終行で(4)うお行うのを忘れずに。
このロジックが、お勧めです。
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
(ただし上記のままでは(略)の部分を入れないと役に立ちません。)
No.6
- 回答日時:
#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 でやるべきものかも知れませんけど、、、)
No.4
- 回答日時:
#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 を入れれば良いハズです。
ご丁寧にありがとうございます。
Call ListCreate(tws, myList, 1)のような引数をつけたサブルーチン?の呼び出しがよく理解できないのです。とくにmyListが配列であろうとは想像できますが具体的にどんな仕組みなのか・・・。
不勉強ですね。すみません。
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
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
ありがとうございます。
ためしたところ、以下の不具合があります。
1.各シートに転記された国別データが全シートとも1番目と最後の2つしかありませんでした。
2.全ブックが開いたままでした。
3.全ブックとも最初に空白なシートがありました。
修正できるものであればよろしくお願いします。
すみません。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Excel(エクセル) エクセルシートのデータを1列飛ばしで別ブックのシートに貼り付けるマクロが知りたい 2 2023/06/05 22:37
- Visual Basic(VBA) 【困っています2】VBA 追加処理の記述を教えてください。 2 2022/08/26 11:42
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Excel(エクセル) エクセルの複数ブックのシートを1つまとめたい 都道府県ごとに47ブックがあり、そのシートのデータを1 5 2022/11/15 14:57
- Excel(エクセル) フォルダ内の複数ブックを同シート名毎に連結させたい 1 2022/04/07 21:24
- Visual Basic(VBA) 【前回の続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/16 16:44
- Excel(エクセル) VBA セルの値と同じ名前のシートにデータを貼り付けするやり方を教えてください 2 2022/05/17 16:26
- Visual Basic(VBA) 【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/24 20:49
- Visual Basic(VBA) vbaについて 主に以下のような設定をしたいです。 Aブックの表の行数が20未満だったら Bブックの 1 2023/06/08 23:40
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・一番好きなみそ汁の具材は?
- ・泣きながら食べたご飯の思い出
- ・「これはヤバかったな」という遅刻エピソード
- ・初めて自分の家と他人の家が違う、と意識した時
- ・いちばん失敗した人決定戦
- ・思い出すきっかけは 音楽?におい?景色?
- ・あなたなりのストレス発散方法を教えてください!
- ・もし10億円当たったら何に使いますか?
- ・何回やってもうまくいかないことは?
- ・今年はじめたいことは?
- ・あなたの人生で一番ピンチに陥った瞬間は?
- ・初めて見た映画を教えてください!
- ・今の日本に期待することはなんですか?
- ・集中するためにやっていること
- ・テレビやラジオに出たことがある人、いますか?
- ・【お題】斜め上を行くスキー場にありがちなこと
- ・人生でいちばんスベッた瞬間
- ・コーピングについて教えてください
- ・あなたの「プチ贅沢」はなんですか?
- ・コンビニでおにぎりを買うときのスタメンはどの具?
- ・おすすめの美術館・博物館、教えてください!
- ・【お題】大変な警告
- ・洋服何着持ってますか?
- ・みんなの【マイ・ベスト積読2024】を教えてください。
- ・「これいらなくない?」という慣習、教えてください
- ・今から楽しみな予定はありますか?
- ・AIツールの活用方法を教えて
- ・最強の防寒、あったか術を教えてください!
- ・歳とったな〜〜と思ったことは?
- ・モテ期を経験した方いらっしゃいますか?
- ・好きな人を振り向かせるためにしたこと
- ・スマホに会話を聞かれているな!?と思ったことありますか?
- ・それもChatGPT!?と驚いた使用方法を教えてください
- ・見学に行くとしたら【天国】と【地獄】どっち?
- ・これまでで一番「情けなかったとき」はいつですか?
- ・この人頭いいなと思ったエピソード
- ・あなたの「必」の書き順を教えてください
- ・14歳の自分に衝撃の事実を告げてください
- ・人生最悪の忘れ物
- ・あなたの習慣について教えてください!!
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルの保護で、列の表示や...
-
文字の色も参照 VLOOKUP
-
ExcelのVlookup関数の制限について
-
VBAで繰り返しコピーしながら下...
-
Excelに自動で行の増減をしたい...
-
エクセルで横並びの複数データ...
-
エクセルのブック分割マクロを...
-
エクセル マクロ 標準モジュー...
-
【条件付き書式】countifsで複...
-
Excelのセルの色を変えた行(す...
-
【エクセル】1列のデータを交...
-
VLOOKアップ関数の結果の...
-
Excelでの並べ替えを全シートま...
-
Excel 2段組み
-
エクセルの列の限界は255列以上...
-
【VBA】シート名と見出しが一致...
-
【VBA】複数のシートの指定した...
-
excel 複数のシートの同じ場所...
-
エクセルで、チェックボックス...
-
エクセルで、book全体の検索&...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ExcelのVlookup関数の制限について
-
エクセルの保護で、列の表示や...
-
文字の色も参照 VLOOKUP
-
Excel の複数シートの列幅を同...
-
Excelでの並べ替えを全シートま...
-
VBAで繰り返しコピーしながら下...
-
【条件付き書式】countifsで複...
-
Excelのセルの色を変えた行(す...
-
エクセルで、チェックボックス...
-
エクセルの列の限界は255列以上...
-
VLOOKアップ関数の結果の...
-
Excelに自動で行の増減をしたい...
-
エクセル マクロ 標準モジュー...
-
【VBA】複数のシートの指定した...
-
Excel VBA ピボットテーブルに...
-
エクセルで横並びの複数データ...
-
【VBA】シート名と見出しが一致...
-
Excel 2段組み
-
SUMPRODUCTにて別シートのデー...
-
スプレッドシートでindexとIMPO...
おすすめ情報