AIと戦って、あなたの人生のリスク診断 >>

下記のようなデータがあります。

支店code顧客名属性顧客コード
A01ああああ10123456
A01いいいい10123457
A01うううう2
A01ええええ10123459
A55かかかか1
A55きききき20123461
A55くくくく30123462
B22ささささ40123463
B22しししし10123464
C56たたたた20123465
D88なななな10123466

全部で約800件ほどです。実際には顧客コード以降にも多くのデータがあります。
これを支店コードごとに別ブックに分割し、さらに顧客コードごとにそれぞれ別シートにしたいのです。(シート名は顧客名)
中には顧客コードが未記入のものがあり、その場合はそのデータは無視します。

とても手におえません。お助けいただけると幸いです。

このQ&Aに関連する最新のQ&A

A 回答 (9件)

#4です。



> これには定義はないのでしょうか?

ChDir myPath があるので、ファイルのフォルダ名は省略しました。

ただ、数字だけの支店名で起こるエラーは、以下の方法で解決できそうですが、ファイル名にフォルダ名も含めなければならないようで、ChDir myPath は、削除してもよさそうです。

ブック作成での、

ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Value & ".xls"  を

ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Text & ".xls"

に。支店ブックを開く時の、

Workbooks.Open c.Value & ".xls"  を

Workbooks.Open myPath & c.Text & ".xls"

に変更してみてください。

あと、気になっていたのですが、最後のほうの

If c.Value = "" Then Exit For

は、いらなかったですね。他にもヘンなところがあるかと思いますが、大目に見てやってください。

この回答への補足

ありがとうございました。
支店コードが数字のみでも出来るようになりました。

あと、
For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"

ですが、この c とはdSheet.Range("A1").CurrentRegion 内のセルという意味ですか?

その場合 Dim c As ~ とかの記述は必要ではないのですかという質問だったのですが。(For Each c In というのは今まで使ったことがないもので。不勉強ですみません)

補足日時:2003/11/09 17:49
    • good
    • 0

> その場合 Dim c As ~ とかの記述は必要ではないのですか



必要です。Dim c As Range ですね。
書き忘れてました。(^_^;)

変数を型を指定して宣言しておくと、エラーの原因を見つけやすくなり、変数の型(データ型)の種類によっては処理速度が速くなったりするそうです。

モジュールの先頭で Option Explicit ステートメントを書いておけばいいのですが、ズボラな僕は書かないことが多いので、こういう事になります。
    • good
    • 0
この回答へのお礼

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

おかげでこちらの加工もうまく出来ました。
大変勉強させていただき、またお助けいただき、感謝感激です。
これからもよろしくお願い致します。

お礼日時:2003/11/09 22:21

続きです。



IDX_R = 1 'インデックスの初期設定
Do Until IDX_R >= UBound(wData, 1) '最終行になったらループを抜ける(条件1)
'---------------------------------------------第1ループ---------------------------------------------
'第1ループ前処理
ShitenKey = wData(IDX_R, 1) '支店キーの設定
Workbooks.Add '新しいブックを作成
Set wNewBook = ActiveWorkbook '新しいブックをwNewBookに設定
Set wCurrentSheet = ActiveSheet '新しいブックのアクティブシートをwCurrentSheetに設定(これが貼り付け対象のシート)
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) '(条件1)又は、支店が変わったら(条件2)ループを抜ける
'---------------------------------------------第2ループ---------------------------------------------
'第2ループ前処理
KokyakuKey = wData(IDX_R, 4) '顧客コードキーの設定
With wCurrentSheet
.Name = KokyakuKey 'シート名を顧客コードにする
.Range(.Cells(1, 1), .Cells(1, 4)).Value = wTitle '1行目にタイトルを設定
End With
CurrentRow = 2 'データを貼り付ける行の初期値設定 '
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) Or _
KokyakuKey <> wData(IDX_R, 4) '(条件1)又は、(条件2)又は、顧客コードが変わったら
'---------------------------------------------第3ループ---------------------------------------------
'第3ループ処理
With wCurrentSheet
.Range(.Cells(CurrentRow, 1), .Cells(CurrentRow, 4)).Value = Array( _
wData(IDX_R, 1), wData(IDX_R, 2), wData(IDX_R, 3), wData(IDX_R, 4))
'↑データの貼り付け(1~4カラムに1度に値を設定しています)
'***関数を入れるとしたらこのあたりでしょう***
End With
IDX_R = IDX_R + 1 'データインデックスのカウントアップ
CurrentRow = CurrentRow + 1 'データを貼り付ける行のカウントアップ
'---------------------------------------------第3ループ---------------------------------------------
Loop
'第2ループ後処理
With wNewBook
.Sheets.Add After:=.Sheets(.Sheets.Count) '新しいシートを作成
End With
Set wCurrentSheet = ActiveSheet 'アクティブシートをwCurrentSheetに設定(貼り付け対象シートの切り替え)
'---------------------------------------------第2ループ---------------------------------------------
Loop
'第1ループ後処理
Application.DisplayAlerts = False 'アラートが出ないようにする
wCurrentSheet.Delete '余分なシートの削除
Application.DisplayAlerts = True 'アラートが出るようにする
With wNewBook
.Sheets(1).Activate '1枚目のシートをアクティブにする。
.SaveAs SavePath & wNow & ShitenKey & ".xls" 'ブックの保存(重複しないように、最初に取得した時刻をファイル名に含める)
.Close 'ブックを閉じる
End With
'---------------------------------------------第1ループ---------------------------------------------
Loop

ここの処理は#2の方が説明されている文章をコード化したものです。
1行目から順番に読み込んでキーが変わったら(ブレイクしたら)何らかの
処理をする。といった感じです。
3重のループを使用していて文章で説明するより各行のコメントを参考にした方が
わかりやすいと思います。(手抜き?^^;)
※ここは、特にHTMLソースを見た方がわかりやすいですよ。

というわけで、説明はこれくらいで・・・
わかりにくい説明があったら指摘してくださいね。

では、いい仕事してくださいね!
    • good
    • 0
この回答へのお礼

ありがとうございました!
解説を読んで勉強したいと思います。
これからもよろしくお願いします。

お礼日時:2003/11/08 12:18

こんにちは。


コメントなしの読み辛いソースですみませんでした。
ご存知だとはかもしれませんが、ソースはページをそのままコピーするより
ソースから拾い出してエディタでタグとか記号を変換したほうが字下げがある
ので少しは読みやすいですよ。

では、かいつまんで説明しますね。
With Application
.ScreenUpdating = False
wSheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
ここでは、画面の更新を止めて、新しくブックを開いた時に1つだけ
シートを開くように設定しています。設定の前に、
wSheetsInNewWorkbook = .SheetsInNewWorkbook
としているのは現在の設定を保存して最後に戻す為です。
ただし、エラー処理を考慮していないので途中でエラーになって止まって
しまったときやマクロの実行を強制的に止めた時などは手動で設定し直さ
なければなりません。この点は改善の余地ありです。

Sheets(1).Copy After:=Sheets(1)
Set wSheet = ActiveSheet
ここでは、ソートする為の前処理としてデータのあるシートをコピーして
元のデータが残るようにしています。そして以降ソートするページをわかりやすく
するために、オブジェクト変数のwSheetにSetしています。
ただし(また^^;)、前提として1枚目のシートにデータがあると仮定しているので、
Const wDataSheetName As String = "データシート"
Sheets(wDataSheetName).Copy After:=Sheets(wDataSheetName)
みたいな感じで記述した方がシート名が変わった時もConst宣言を変更するだけでいいので
保守性がよくなると思います。(改善点2)

次はソートの部分です。
最初の投稿時にも書きましたがエクセルらしいやり方です。(と勝手に思ってる^^;)

StartRow = 3
With wSheet
wTitle = .Range(.Cells(2, 1), .Cells(2, 4))
EndRow = .Cells(65536, 1).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 4), Order1:=xlAscending, _
Header:=xlNo
EndRow = .Cells(65536, 4).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 1), Order1:=xlAscending, _
Key2:=.Cells(StartRow, 4), Order2:=xlAscending, _
Header:=xlNo
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
Set wDataRange = Nothing
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Set wSheet = Nothing

ざっと見てもらったら、わかると思いますが2回ソートしています。
最初のソートはデータの3行目から顧客番号の昇順にソートしています。
これは「顧客コードが未記入のものがあり、その場合はそのデータは無視」
と言う条件があるので、未記入のデータを取り除くためです。
コツは最終行の設定方法で、1回目は
EndRow = .Cells(65536, 1).End(xlUp).Row
として、支店が最後に入力されている行を最終行としているのに対して、2回目は
EndRow = .Cells(65536, 4).End(xlUp).Row
として、顧客番号が最後に入力されている行を最終行としているのです。
途中にソートを入れることによって顧客番号が未入力の行は下の方に集まるので
結果として顧客番号未入力のデータは無視されることになるのです。
そして、2回目のソートでは支店、顧客番号の順番にソートし直しています。

ソートが終わったら、
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
バリアント型の変数wDataにソート後の値をすべてぶち込んでいます。
これは、この後の処理でRangeオブジェクトの参照を出来るだけ減らす事によって
処理速度を改善するためです。
ここの注意点は最終行を"EndRow + 1"として1行余分にデータを取り込むことによって
以降の処理でテーブルオーバーを起こさないようにすることです。

----------------------
長いので、いったん投稿します。
    • good
    • 0

おもしろそうなので、作ってみました。


ちょっと、ややこしいですが・・・
でも、処理は早いと思いますよ。

ソートの部分はExcelらしくしましたが、
分割部分はただのコントロールブレイクです。

調子に乗って作ってたら遅くなってしまったので
コメントと解説は省きます。
(フォローできる方がいたらお願いします)
暫くクローズせずにおいといてもらえるなら、
明日か明後日にでも補足します。

-----------------------------------------------
Private Sub XXX()
Dim wNewBook As Excel.Workbook
Dim wCurrentSheet As Excel.Worksheet
Dim wSheet As Excel.Worksheet
Dim wDataRange As Excel.Range

Dim wNow As String
Dim wSheetsInNewWorkbook As Long
Dim wTitle As Variant
Dim wData As Variant
Dim IDX_R As Long
Dim StartRow As Long
Dim EndRow As Long
Dim CurrentRow As Long

Dim ShitenKey As String
Dim KokyakuKey As String

Const SavePath As String = "D:\temp\"

With Application
.ScreenUpdating = False
wSheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With

Sheets(1).Copy After:=Sheets(1)
Set wSheet = ActiveSheet
wNow = Format$(Now, "YYYY-MM-DD-HH-NN-SS_")

StartRow = 3
With wSheet
wTitle = .Range(.Cells(2, 1), .Cells(2, 4))
EndRow = .Cells(65536, 1).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 4), Order1:=xlAscending, _
Header:=xlNo
EndRow = .Cells(65536, 4).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 1), Order1:=xlAscending, _
Key2:=.Cells(StartRow, 4), Order2:=xlAscending, _
Header:=xlNo
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
Set wDataRange = Nothing
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Set wSheet = Nothing

IDX_R = 1
Do Until IDX_R >= UBound(wData, 1)
ShitenKey = wData(IDX_R, 1)
Workbooks.Add
Set wNewBook = ActiveWorkbook
Set wCurrentSheet = ActiveSheet
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1)
KokyakuKey = wData(IDX_R, 4)
With wCurrentSheet
.Name = KokyakuKey
.Range(.Cells(1, 1), .Cells(1, 4)).Value = wTitle
End With
CurrentRow = 2
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) Or _
KokyakuKey <> wData(IDX_R, 4)
With wCurrentSheet
.Range(.Cells(CurrentRow, 1), .Cells(CurrentRow, 4)).Value = Array( _
wData(IDX_R, 1), wData(IDX_R, 2), wData(IDX_R, 3), wData(IDX_R, 4))
End With
IDX_R = IDX_R + 1
CurrentRow = CurrentRow + 1
Loop
With wNewBook
.Sheets.Add After:=.Sheets(.Sheets.Count)
End With
Set wCurrentSheet = ActiveSheet
Loop
Application.DisplayAlerts = False
wCurrentSheet.Delete
Application.DisplayAlerts = True
With wNewBook
.Sheets(1).Activate
.SaveAs SavePath & wNow & ShitenKey & ".xls"
.Close
End With
Loop

With Application
.ScreenUpdating = True
.SheetsInNewWorkbook = wSheetsInNewWorkbook
End With

Set wNewBook = Nothing
Set wCurrentSheet = Nothing

End Sub
-----------------------------------------------
    • good
    • 0
この回答へのお礼

ありがとうございました。
テストデータでやってみたらうまく行きました。

ただ、実際には分割したブックの各シートにそれぞれ数式を埋め込む作業があるので書いていただいたコードを必死で理解しようとしているところです。
なかなかわかりませんので解説していただけると幸いです。

なお、データは支店コードで順番にならんでいますのでソートは必要ないと思うのですが。

お礼日時:2003/11/05 11:30

#3です。



やっぱり#2さんの方法が、きれいなコードが出来そうですね。
僕のだと顧客コードに重複があると、同じ名前のシートを作ろうとして必ずエラーになります。これを避けようとするとコードが複雑になるし、実行時間も余分にかかることになります。また、同一顧客のデータをシートにまとめるのにも、ソートしてあったほうが楽に出来そうです。

この回答への補足

ありがとうございます。だいぶわかってきました。
ただ、

For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"

のところで変数c (支店コードですよね?)がいきなり出てくるのですが、これには定義はないのでしょうか?

それから支店コードがA01のような文字列の場合は正常にうごきましたが、335のような数字だとエラーになりました。
どう対処すればいいでしょうか?お教えください。

補足日時:2003/11/08 12:10
    • good
    • 0

これだけで実用に耐えられるとは思いませんので、ご参考までに。

手を入れやすいように機能別に分けて書いたつもりです。
データ中の顧客コードは、重複は無いものとしています。

Sub test()
Dim dSheet As Worksheet, Siten As Range, i As Long, n As Long
Dim Kyaku As Range, Data As Range, mySh As Worksheet, myPath As String

myPath = "C:\Documents and Settings\Owner\デスクトップ\分割\" '-----パス名を環境に合わせて変更してください。
Application.ScreenUpdating = False
Set Data = Worksheets(1).Range("A1").CurrentRegion
'-------------------------------------------------------------------支店の取得
Set Siten = Data.Columns(1)
Set dSheet = Worksheets.Add(After:=Worksheets(1)) '作業用シート
For i = 3 To Siten.Rows.Count
If Application.WorksheetFunction.CountIf(dSheet.Columns(1), Siten.Rows(i).Value) = 0 Then
n = n + 1
dSheet.Columns(1).Rows(n).Value = Siten.Rows(i).Value
End If
Next
'------------------------------------------------------------------ブック作成
For i = 1 To dSheet.Range("A1").CurrentRegion.Rows.Count
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Value & ".xls"
ActiveWorkbook.Close SaveChanges:=True
Next
'-------------------------------------------------------------------シート作成
Set Kyaku = Data.Columns(2)
ChDir myPath
For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"
For i = 3 To Kyaku.Rows.Count
If Siten.Rows(i).Value = c.Value And Data.Columns(4).Rows(i).Value <> "" Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Kyaku.Rows(i).Value
ActiveSheet.Range(Data.Address).Rows(1).Value = Data.Rows(i).Value
End If
Next
For Each mySh In Worksheets
Application.DisplayAlerts = False
If Left(mySh.Name, 5) = "Sheet" Then '余分なシートの削除
If ActiveWorkbook.Worksheets.Count <> 1 Then mySh.Delete
End If
Next
ActiveWorkbook.Close SaveChanges:=True
If c.Value = "" Then Exit For
Next
dSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

エクセルの仕様では、ブック中のワークシートの数はメモリに依存すると思いました。数が多くなりそうですが、大丈夫なのでしょうか。
    • good
    • 0
この回答へのお礼

ありがとうございました。
テストデータでやってみたらうまく行きました。

ただ、実際には分割したブックの各シートにそれぞれ数式を埋め込む作業があるので書いていただいたコードを必死で理解しようとしているところです。
なかなかわかりませんが。

お礼日時:2003/11/05 11:27

これは下記ロジックが単純で、古く(コンピュタ初期から事務計算で)から使われていて最適法と思います。


(1)まず支店コード(第1キー)、顧客コード(第2キー)(必要あれば第3キーを考える)でエクセルでソート
する。(エクセルで幸いソート出来ます。昔はソート・マージプログラムでやりました。)
(2)各行全800行について、直前の行レコードと比べて、A支店コードが変わったか(不等か)
  B顧客コードが変わったか(同じでないか)
を見ます(コントロールブレイクという。支店別、顧客別にページ変えをする時必須のテクニックでした)。
直前の行の第1キー、第2キーは変数に記憶します。
(3)支店コードが変わったら、前(現在)のブックはクローズし、新しいブックをオープンします。
行ポインタは、次の第1シートの最初行を指す。
(4)顧客コードが変ったら、別シートに書きに行きます。行ポインタは次のシートの最初行を指す。
(5)骨格だけなら10行ぐらいかなと思います。
ソートが済むと、総なめ比較をしなくても良いのが重宝するのです。「存在するかチェックする」のところで総なめ
が行われ方法が多いです。これを昔は嫌いました。今はCPUのスピードがUPして、平気化してるようです。
    • good
    • 0
この回答へのお礼

ありがとうございます。
今回のデータはソートしなくとも順番にならんでいますのでいいと思うのですが、自分ではとてもとても・・・。
お恥ずかしいです。

お礼日時:2003/11/05 11:25

単純に支店Codeだけで分割するなら…


まず、データファイルを格納するフォルダを指定しておきます。
※ その配下にファイル名を支店Codeと同じものにしてファイルを作成していきます。

If文の条件で、支店Codeを抜き出します。
抜き出した支店Codeと同じファイル名が存在するかチェックします。
※ 支店Codeと同名のファイル存在する場合それをオープンする。
※ 支店Codeとして同名ファイルが無い場合は作成してオープンする。

あとは、支店Codeを抜き出した行をオープンしたファイルの最終行に書き込めば完了です。
これを元ファイルの最終行まで繰り返す様にループしてください。

参考URL:http://www.eastwest-net.co.jp/vba/

この回答への補足

さっそくありがとうございます。

自分でもなんとかここまでは出来たのですが、顧客名をシート名にして顧客のデータを1シートづつにする方法が分からないのです。

Sub BUNKATSU_2()
Dim wb As Workbook
Dim StartRow As Integer
Dim EndRow As Integer
Dim 新ファイル名 As String

i = 3 '(2行目までタイトルのため)
StartRow = 3

Do
DoEvents

ThisWorkbook.Activate
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then

EndRow = i

Range("1:2," & StartRow & ":" & EndRow).Copy

Set wb = Workbooks.Add

wb.Activate
wb.Sheets("Sheet1").Range("A1").Select
ActiveSheet.Paste

Application.CutCopyMode = False

新ファイル名 = Cells(3, 1)

ChDir "C:\Windows\デスクトップ\分割"
ActiveWorkbook.SaveAs FileName:="C:\Windows\デスクトップ\分割\" & 新ファイル名 & ".xls"

ActiveWindow.Close

StartRow = i + 1

End If

i = i + 1

Loop Until (Cells(i, 1).Value = "")

End Sub

これで支店コード名のファイルは出来るのですが・・・。

補足日時:2003/11/04 17:46
    • good
    • 0

このQ&Aに関連する人気のQ&A

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

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

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

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

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

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

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

Aベストアンサー

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

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)...続きを読む

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

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

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

シート2 シート名:uriage20130515
A列         B列
20130515000004 300
20130515000006 100

シート3 シート名:uriage20130518
A列         B列
20130518000004 300

シート4 シート名:uriage20130519
A列         B列
20130519000001 500
20130519000004 300

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

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

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

よろしくお願いします。

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

シート1
A列(日付8ケタ+商品番号6ケタ) B列(売上額)
20130515000004           300
20130515000006           100
20130518000004           300
20130519000001           500
20130519000004           300
・・・           ...続きを読む

Aベストアンサー

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

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)

 ’CSVに書き出し
  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


ファイルメニューから終了してエクセルに戻る
ALT+F8を押しマクロを実行すると,CSVを書き出す。



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

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

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
 a...続きを読む

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む

Qエクセルで各シート毎にブックに分割したい

エクセルの1つのブックに複数の名前がついたシートがあり、その各シート毎にシート名のブックに分割したいのです。
シートが少なければ手作業で分割するのですが、100枚近くのシートがあるので、できればマクロで一括処理できれば助かるのですが。
過去ログで複数のブックのシートを一つのブックにまとめる事例がありましたので、その逆もできると思うのですが。
よろしくお願いします。

Aベストアンサー

こんばんは。

こんな感じで如何でしょうか?

Sub splitBook()

Const path As String = "C:\" '\まで記述

Dim bk As Workbook
Set bk = ActiveWorkbook

Dim st As Worksheet
For Each st In bk.Sheets

Workbooks.Add
st.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.SaveAs path & st.Name & ".xls"
ActiveWorkbook.Close

Next

End Sub

Qエクセルでセルの色番号を表示する方法

エクセルでセルの色番号を表示する方法が下記URLに記載されているのですが下記の方法にそったやり方でB1のセルではなくA2に色番号を表示する方法を知りたいのですがどなたか教えて頂けますか?

http://miyahorinn.fc2web.com/faq/faq030.html

Aベストアンサー

>A1のセルの背景色を色番号をA2に表示させたいのですが
=GET.CELL(63,!$A1)+NOW( )*0
にすれば、1行目の色番号となります。
=GET.CELL(63,!$A$1)+NOW( )*0
とすれば、常にA1セルと云う事になります。

追記 4.0マクロの機能ですが
背景色を変えただけでは、計算は実行されません。
再計算(F9)を押すか、シート上のセルで何らかの入力作業を行った際に
更新されます。

QExcel VBAで複数シートをコピーする

Excel VBAで複数のシートを新たらしいブックにコピーする方法が分かりません。

一応、Selectで全てのシートを選択し
コピーする方法は分かるのですが
出来ればSelectなどの画面遷移をプログラム内に含ませたくありません

シートは n件存在します。
ご存知の方がおられましたら
ぜひ、教えて頂けないでしょうか?

Aベストアンサー

すいません、勉強不足でした。
ただ単純に「全てのシートを選択」し「新規ファイルにコピー」という動作であれば、
sheets.Select
sheets.Copy
だけでできました。

QExcelの終了時に「クリップボードに…」を出なくする方法

Aファイル上でBファイルを開いて、BファイルのデータをAファイルにコピーして、Bファイルを閉じるマクロ(VBA)を作っています。
しかし、Bファイルを閉じるとき「クリップボードにデータがあり、他のアプリケーションで使用する場合は…」とかいうメッセージが出ます。
他のアプリケーションで使う予定はないので、このメッセージを出さずにBファイルを閉じたいのですが、どなたかおわかりの方、教えてください。
ちなみに、マクロの最後の部分は次のようになっています。

Application.Goto Reference:=strName
Selection.Copy
Windows(strMasterName).Activate
Application.Goto Reference:=strName & strNo
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Windows(strFileName).Activate
Sheets(strBase).Select
ActiveWindow.Close
Windows(strMasterName).Activate

Application.ScreenUpdating = True
MsgBox "コピーが終了しました"

Aファイル上でBファイルを開いて、BファイルのデータをAファイルにコピーして、Bファイルを閉じるマクロ(VBA)を作っています。
しかし、Bファイルを閉じるとき「クリップボードにデータがあり、他のアプリケーションで使用する場合は…」とかいうメッセージが出ます。
他のアプリケーションで使う予定はないので、このメッセージを出さずにBファイルを閉じたいのですが、どなたかおわかりの方、教えてください。
ちなみに、マクロの最後の部分は次のようになっています。

Application.Goto Reference:=...続きを読む

Aベストアンサー

マクロの最後に
Application.CutCopyMode = False
を追加してみて下さい。
切り取りモードまたはコピー モードを解除し、点滅している枠線を取り除きます。

Q【Excel VBA】マクロでExcel自体を終了させたい

環境:WindowsXP、Excel2003

マクロでエクセルを終了(ブックを閉じて、アプリケーション自体も終了)させたいのですが、以下のコードではアプリケーションが閉じてくれません。

ThisWorkbook.Close
ExcObj.Quit
Application.Quit

どこか悪いところはありますでしょうか?

よろしくお願いします。

Aベストアンサー

普通に考えれば質問者のコードで上手くいきそうですが
hana-hana3さんの回答にもあるようにThisWorkBook.Closeでコード終了となりますので
Application.QuitをThisWorkBook.Closeの前にもってこないといけません。
Application.Quitはそれがあるプロシージャのコードが全て終わるまで
その実行を保留するちょと特別動作をします。

'-------------------------------------
 Application.Quit
 ThisWorkbook.Close
'-------------------------------------
 
 

QExcelのファイルからシート毎にファイルを作成する方法

複数のシートで構成されているひとつのExcelファイルからシートごとに分割してファイルを作成(保存したいです)

具体的には、

ファイル名 file.xls
 含まれているシート Sheet1 Sheet2 Sheet3

このfile.xlsから自動でSheet1.xls Sheet2.xls Sheet3.xlsという
ファイルを作成してそれぞれのシートだけを保存する方法があれば教えてください。

標準の機能でなければ、フリーソフトなど別のソフトを使った方法でもかまいません。

Aベストアンサー

>シートの数が多いので、自動化マクロを作る方法を考えます。
手作業でするのが面倒と思えば、VBAでやらせるほかありません。
ーーー
VBAの経験はありますか。マクロの記録の回答に対し、反応が鈍いところ、質問も丸投げ的なことからも、経験が少ないのでは。多くの経験が必要です。
参考までに、私としては苦心したコードを挙げておきますが、判ってもらえるのかどうか。
Sub test02()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
s = wb1.Sheets.Count
MsgBox s & "枚"
For i = 1 To s
Workbooks.Add.SaveAs Filename:="AD" & i & ".xls"
wb1.Worksheets(i).Copy before:=Workbooks("AD" & i & ".xls").Worksheets(1)
Workbooks("AD" & i & ".xls").Worksheets(1).Name = "ADS" & i
Next i
End Sub
ーー
質問のファイル名 file.xlsに当たるブックの標準モジュールに上記を貼り付けます。
上記では新しく出来たブックの名前は"AD" & i & ".xls"で規定されます。適当に変えてください。
新しく出来たブックのシート名は上記では、Name = "ADS" & i
で規定されます。シートが皆同じでよければ定数だけにしてください。
以上は、シートのコピーというエクセルの良く使う機能を使ったもの(操作をVBA化したもの)です。他にもやり方があると思いますが、一番コードが短いかなと思う。

>シートの数が多いので、自動化マクロを作る方法を考えます。
手作業でするのが面倒と思えば、VBAでやらせるほかありません。
ーーー
VBAの経験はありますか。マクロの記録の回答に対し、反応が鈍いところ、質問も丸投げ的なことからも、経験が少ないのでは。多くの経験が必要です。
参考までに、私としては苦心したコードを挙げておきますが、判ってもらえるのかどうか。
Sub test02()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
s = wb1.Sheets.Count
MsgBox s & "枚"
For i = 1 To s
Work...続きを読む

Q複数の同じフォーマットのファイルを新しいブックで一つのシートにまとめる方法

仕事で、各部署から送られてきた、同じフォーマットのファイル(シート1にのみデータ有)が50個近くあります。
それを新しいブックで一つのシートにまとめなくてはいけません。
地道にコピペするのは時間がかかるのでマクロで処理を行いたいと思います。
マクロでの処理方法ご存知の方、処理方法の載っているサイトをご存知の方、もしくはマクロより簡単な方法がありましたら教えてください。

あと、逆に一つのシートをいくつかのファイルに振り分けていく方法もご存知でしたら教えて下さい。
よろしくお願いします。

Aベストアンサー

すみません。質問を勘違いしていました。
>新しいブックで一つのシートにまとめなくてはいけません
でしたね。
Sub Sample1()
Dim buf As String, i As Long
Dim j
buf = Dir(Sheets("Sheet1").Range("A1").Value & "\*.xls")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet1").Range("A1").Value & "\" & buf
Sheets("Sheet1").Range("A1:J1000").Copy
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False
buf = Dir()
Loop
End Sub
で試してみてください。使い方などは
http://oshiete1.goo.ne.jp/qa4225063.html
を参照してみてください。同じ質問があったので気がつきました。

すみません。質問を勘違いしていました。
>新しいブックで一つのシートにまとめなくてはいけません
でしたね。
Sub Sample1()
Dim buf As String, i As Long
Dim j
buf = Dir(Sheets("Sheet1").Range("A1").Value & "\*.xls")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet1").Range("A1").Value & "\" & buf
Sheets("Sheet1").Range("A1:J1000").Copy
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCop...続きを読む


人気Q&Aランキング