ExcelVBAを使っての振り分け処理

「ALLDATA」というシートに
店名　商品コード　数量　金額　という項目があり、
日々、データを400件位入力しています。
（データ件数は日々変動）

これを商品コードを見て、その商品コードと同じシート名の表に、
データをコピーし振り分けていく処理をボタン一つで
出来るようにしたいのです。
振り分け出来なかったデータは、(商品コードの入力ミスなど)
同じファイルの「エラー」シートに振り分けられるようにしたいのです。

何かいい方法はないでしょうか？

No.6 ベストアンサー 回答者： Wendy02 回答日時： 2006/01/31 00:44

aube2003さん

こんばんは。Wendy02です。

＞早速試させて頂きました。全角だとうまくいきませんでしたので、半角に直してみると・・・。
＞大・大感動です。

私は驚きです。本当は、うまくいくほうが、30%ぐらいだと思っていましたから。気になる点は、クリアできないかもしれないと思っていましたから。方法はあるのですが、すごく面倒になるのです。

＞このプログラムに興味があると言うか、

これは、以前、オートフィルタでコピー＆ペーストすると、非表示のものはコピーされないことに気が付いたときに、この方法を思いつきました。それと、私のコードから余計なものを取り去ると、「なんだ」こんなことかって思われるかと思います。

自分だけのものには、そんな面倒なことはしません。

掲示板で、相手の環境が見えない状態で、文字だけでやり取りする以上、最低限のエラー処理というのが、だんだん膨らんできて、現在のスタイルになっているわけで、本当は、ものすごく初歩的なことしかしていないのです。だから、ちょっとしたアイデアだけなのですね。
よかったです。

この回答へのお礼

こんばんは。入力ミスによるエラーの振り分けができるのがほんとうに嬉しいです。
助かりました。さっそく使っています。
どうもありがとうございました。

お礼日時：2006/01/31 21:38

No.5 回答者： Wendy02 回答日時： 2006/01/30 15:11

こんにちは。

Wendy02です。

気がかりな点は、一番最後に書いておりますが、とりあえず試してみてください。
うまくいかない場合は、全面的に変更するか、こちらの方で、別のチェックプログラムを提示いたします。

取り付け方:

AllData シートに、表示－ツールバーで、コントロールツールボックスを出して、その中の「CommandButton（コマンドボタン）」を取り付けてください。貼り付けたら、コントロールツールバーの中の　青い三角定規が凹んでいることを確認して、そのボタンをダブルクリックしてください。

画面が、VB Editor 画面になりますから、Private Sub ～ End Sub の文字が現れていますから、その中に、以下を貼り付けてください。

'(ALLDATAのシートのモジュールに)
Private Sub CommandButton1_Click()
'-------------------------------------
　 Call AllDataDivising　 '←この部分を貼り付けます。
'-------------------------------------
End Sub

次に、VB Editoの画面のメニューの挿入－[標準モジュール] がありますから、それをクリックして、以下を貼り付けてください。貼り付け終わったら、上の凹んだ青い三角定規がでていたら、戻してください。

そして、Alt + Q で、この画面を閉じます。 コントロールツールバーが出ていたら、それは、邪魔ですから、見えないようにしてください。

'(標準モジュールへ)
'---------------------------------------------
Sub AllDataDivising()
　 'データの切り分けプログラム
　 Dim ShAllData As Worksheet
　 Dim sh As Variant
　 Dim i As Long
　 Dim j As Long
　 Dim shNames() As Variant
　 Dim ret As Integer
　 Dim LastCol As Integer '元データの右端の列数を取っておく
　 Dim TopCell As Range
　
　 On Error GoTo ErrMsg
　 '全角半角は、注意してください。
　 Set ShAllData = Worksheets("ＡＬＬＤＡＴＡ")　'※
　
　 'A1 から始まる場合は、変更する必要なし
　 Set TopCell = ShAllData.Range("A1")
　 Application.Goto TopCell
　 If ShAllData.AutoFilterMode = True Then TopCell.AutoFilter
　
　 For Each sh In ThisWorkbook.Worksheets
　　　'ALLDATA/エラーではない場合ものの名前をストック
　　　If sh.Name <> ShAllData.Name And sh.Name <> "エラー" Then
　　　　 ReDim Preserve shNames(i)
　　　　 shNames(i) = sh.Name　'※
　　　　 i = i + 1
　　　End If
　 Next sh
　 Application.ScreenUpdating = False
　 With TopCell
　　　.End(xlToRight).Offset(, 1).Value = "済" '済判を入れる
　　　LastCol = .End(xlToRight).Column
　　　
　　　'フィルタモードチェック
　　　If .Parent.AutoFilterMode = False Then
　　　　 .AutoFilter
　　　End If
　　　
　　　'ループ
　　　For j = LBound(shNames) To UBound(shNames) + 1
　　　　 If j < UBound(shNames) + 1 Then
　　　　　　TopCell.AutoFilter Field:=2, Criteria1:=shNames(j)　'※
　　　　　　Else
　　　　　　.Parent.ShowAllData
　　　　　　TopCell.AutoFilter Field:=LastCol, Criteria1:="<>x", Operator:=xlAnd 'xが入らない場合
　　　　 End If
　　　　 On Error Resume Next
　　　　 ret = Empty
　　　　 ret = Range(TopCell, Cells(65536, TopCell.Column).End(xlUp)).SpecialCells(xlCellTypeVisible).Count
　　　　 On Error GoTo 0
　　　　 If ret > 1 Then
　　　　　　If j < UBound(shNames) + 1 Then
　　　　　　　 TransferData .Range(TopCell, TopCell.End(xlDown).Resize(, LastCol)), shNames(j), LastCol
　　　　　　　 Else
　　　　　　　 TransferData .Range(TopCell, TopCell.End(xlDown).Resize(, LastCol)), "エラー", LastCol
　　　　　　End If
　　　　 End If
　　　Next
　　　.Parent.AutoFilterMode = False
　　　.CurrentRegion.Columns(LastCol).ClearContents
　 End With
　 Application.ScreenUpdating = True
ErrMsg:
　 'エラー処理
　 Set TopCell = Nothing: Set ShAllData = Nothing
　 If Err.Number > 0 Then
　　　MsgBox Err.Number & " :" & Err.Description
　　　Else
　　　MsgBox "終了しました。", vbInformation
　 End If
End Sub

Sub TransferData(rng As Range, shName As Variant, LastCol As Integer)
'貼り付け用サブルーチン
Dim dummy As Variant
　 dummy = Evaluate(shName & "!A1")
　 On Error GoTo ErrMsg
　If Not IsError(dummy) Then
　 With rng
　 .Offset(1).Resize(.Rows.Count - 1).Copy _
　　Worksheets(shName).Range("A65536").End(xlUp).Offset(1)　'※
　 .Offset(1, LastCol - 1).Resize(rng.Rows.Count - 1, 1).Value = "x"
　 End With
　End If
　Exit Sub
ErrMsg:
　MsgBox Err.Number & " :" & Err.Description
End Sub

'---------------------------------------------

※　なお、シート・商品コードともに、全角を用いるのは、失敗する可能性が高くなります。もし、全角・半角を間違えた場合は、出力の途中では、その部分のシートだけが出力せずに、終わります。一応、コードの中で、全角・半角で影響を受ける部分を「※」で表示しておきました。

また、最初にこの種のエラーが出るときは、「9 : インデックスが有効範囲にありません」と出力します。

この回答へのお礼

こんばんは。
早速試させて頂きました。全角だとうまくいきませんでしたので、半角に直してみると・・・。
大・大感動です。
これがまさにボタン一つでやりたかったことです。
ほんとうにありがとうございます。

このプログラムに興味があると言うか、こういう言いい方は変ですが、
流れを一つ一つ理解できるように勉強させていただきます。

ほんとうにありがとうございました<(_ _)>

お礼日時：2006/01/30 23:59

No.4 回答者： Wendy02 回答日時： 2006/01/29 02:21

こんばんは。

Wendy02です。

返事が遅くなってすみません。
１つだけ問題が発生してしまいました。それは、

　ＡＡＡ／ＢＢＢ／ＣＣＣ

実際には、シート名には、全角・半角の区別があるので、それが、はっきりしないと、前に進まないのです。例えば、セルには、全角・半角で書いているけれども、ワークシートは半角ですとか、全角ですとか、決まっていないとちょっとややこしくなります。出来なくはないのですが、その分、最初の入り口のところでコードが変ってきてしまいます。

この回答への補足

こんばんは。回答ありがとうございます。
商品コード、シート名ともに全角で入力しています。

言葉足らずで申し訳ありません。
どうぞ宜しくお願い致します。

補足日時：2006/01/29 22:37

No.3 回答者： Wendy02 回答日時： 2006/01/25 11:15

こんにちは。

ちょっと、私からもアドバイス
これは、Excelですので、やり方は、ある程度決まってきます。
まず、コードのベースになる

「商品コードと同じシート名の表」を用意します。
これは、私ですと、Public CONST で、使う時に、配列変数に置き換えますが、難しいようでしたら、どこかにリストを置いてください。

これを使って、「ALLDATA」のデータをオートフィルターで、分けて、それをコピーしていきます。

フィルターオプションでもよいのですが、オートフィルタのほうが、簡単です。コピーしていくたびに、補助列に、チェッカー(例:1）などを付けていきます。

そして、最後に、そのチェッカーがついていないものを、オートフィルターで選び出して、「エラー」シート送りにします。

まあ、記録マクロでは、ループがうまくいかないかと思いますが、ひとつ、サンプルと全体のデータのレイアウトを公開していただければ、他の人でも作れると思います。今の段階では、アイデアだけになってしまいます。

この回答への補足

アドバイスありがとうございます。
オートフィルタは普段使っていますが、マクロで動かしたことがなく、
エラーの部分と毎回変わるセル範囲の取得でつまずいていました。

お言葉に甘えて少しサンプルを書いてみます。
［ALLDATA］シート
店名　　商品コード　　数量　　　金額
東京　　ＡＡＡ　　　　　１　　　１００
東京　　ＢＢＢ　　　　　２　　　６００
東京　　ＡＡＡ　　　　　１　　　１００
大阪　　ＣＣＣ　　　　　５　　２０００
大阪　　ＡＡＡ　　　　　１　　　１００
名古屋　ＣＣＣ　　　　　５　　２０００
東京　　　　　　　　　　３　　　３００
大阪　　ＤＤＤ　　　　　１　　　１００
名古屋　ＡＡＡ　　　　　１　　　１００

↓振り分け後

［ＡＡＡ］シート
東京　　ＡＡＡ　　　　　１　　　１００
東京　　ＡＡＡ　　　　　１　　　１００
大阪　　ＡＡＡ　　　　　１　　　１００
名古屋　ＡＡＡ　　　　　１　　　１００
［ＢＢＢ］シート
東京　　ＢＢＢ　　　　　２　　　６００
［ＣＣＣ］シート
大阪　　ＣＣＣ　　　　　５　　２０００
名古屋　ＣＣＣ　　　　　５　　２０００
［エラー］シート
東京　　　　　　　　　　３　　　３００
大阪　　ＤＤＤ　　　　　１　　　１００

・・・とこのような処理をしたいのです。
宜しくお願い致します<m(__)m>

補足日時：2006/01/25 22:38

No.2 回答者： Hallo_Pain 回答日時： 2006/01/25 10:05

実装するには、それなりのプログラム記述がいるように思います。

大まかにいうと（そのままになっちゃいますが（汗））
１）ALLDATAシートの商品コードを１件ずつ取得
２）取得した商品コードで該当するシートを検索。
３）該当したシートに情報を記述
　　該当しなければ「エラー」シートに記述

てなかんじでしょうか。
エクセルのマクロ記録機能をつかえば、
それなりのサンプルソースができるので、実装しやすいと思います。
でも、
商品コードが何件あるか？
新しい商品コードができた場合、シートを作成するのか？
とか疑問もあります。
商品コード単位で状況を確認するなら、入力をアクセスに
するのもひとつの手かもしれません。

この回答への補足

ご回答ありがとうございます。
流れはそのような感じです。
商品コードはＭＡＸ１０件くらいです。
マクロ機能を使いながら、いろいろ改良しているのですが、
素人にはハードルが高くて・・・。

補足日時：2006/01/25 22:30

No.1 回答者： azzu0707 回答日時： 2006/01/25 00:12

Select Caseでよいのでは？

この回答への補足

VBA初心者で、マクロの記録機能を参考にしていたため、
Select Case　の後の構文でつまづいてしまいます。
ですが、条件分岐の方法はいろいろありそうですので、
もう少しいろいろ試してみます。
ご回答ありがとうございます。

補足日時：2006/01/25 22:53