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

質問

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

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

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

回答No.6

Wendy02 · ベストアンサー

aube2003さん

こんばんは。Wendy02です。

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

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

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

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

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

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

お礼

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

回答No.5

Wendy02

こんにちは。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 : インデックスが有効範囲にありません」と出力します。

お礼

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

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

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

回答No.4

Wendy02

こんばんは。Wendy02です。

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

　ＡＡＡ／ＢＢＢ／ＣＣＣ

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

補足

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

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

回答No.3

Wendy02

こんにちは。

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

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

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

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

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

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

補足

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

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

↓振り分け後

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

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

回答No.2

Hallo_Pain

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

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

補足

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

回答No.1

azzu0707

Select Caseでよいのでは？

補足

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