データを各シートに自動振り分け

質問

データシートA2にデータを貼付けると営業所ごとに各シートにデータを振分してほしいです。データシートは都度上書きとなりますが、振分用シートのデータは上書せずに、最後の行から挿入させたいです。品番が重複するデータが挿入された場合、新しいデータを削除。振分用シートはすべて、５行目が項目行となります。
どのようなコードを作成すればよいのかVBAに詳しい方、アドバイスよろしくお願いいたします。

回答No.12

kkkkkm

> その場合、重複データは転記されないようにしたいです。

データシートのC列と転記先のE列での重複ですよね。
もともと、重複するデータは転記していません。
と何度も回答してます。実際実行して転記されますか？
たとえば空の転記先があったとして同じデータシートでそれを何度繰り返しても最初の一回しか転記しません。

回答No.11

n-jun

まず要望を伝える前に書かれているコードの意味を理解するか、その説明を求めるべきだと思いますよ。
丸ごと貼り付けてから重複を削除するって方法しかご存じないみたいなので、そのコードがない事に違和感があるのでしょう。

でも丸ごとではなく最初から必要最小限のデータを貼り付けるって手段もある事を知って受け入れるべきかと。
方法は回答者それぞれで幾つも存在するものです。
固定概念は持たない方が宜しいかも。
検証し結果が違うのならその違う点を挙げるべきでしょ。

仮にこれが課題であるってなら、その手段は質問者さんの教わった範囲でしかないのかもですが、回答者は何を教わって出された課題なのかはわかりませんし。
貼り付け後の重複削除なら教えて!gooにて回答が付いているようですよ。

回答No.10

kkkkkm

> もう一点…品番が重複した場合削除してほしいのですが、コード追加して貰えますでしょうか？

もともと重複する新しい品番のデータは転記していません。

補足

すみません説明不足でした(>_<)データシートには何度もデータを上書きすることになるのですが、振分済みの品番と重複するデータが出ることがあります。その場合、重複データは転記されないようにしたいです。わかりにくくてすみません。。

回答No.9

n-jun

No.7さんの件につきましては、No.4のリンク先で既に実施されてます。
けどうまくいかなかったそうです。
ダミーでは成功するけど実際のデータではミスるらしい。

回答No.8

kkkkkm

> データをC列６行目から貼付けられるように出来ますか？

すみません、A列から転記してました。C列からでしたね。
半角全角混在してるのか不明ですので、どちらでもいいように以下のように変更しました。

> 現在、二行目からデータの一部だけ反映されております。

すみませんこの意味が分かりません。

Sub Test()
Dim c As Range
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim FRange As Range
Dim i As Long, SheetNo As Long

Set Sh1 = Sheets("データ")
For Each c In Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp))
SheetNo = 0
For i = 1 To Sheets.Count
If StrConv(Sheets(i).Name, vbWide) = StrConv(c.Text, vbWide) Then
SheetNo = i
Exit For
End If
Next
If SheetNo <> 0 Then
Set Sh2 = Sheets(SheetNo)
Set FRange = Sh2.Range(Sh2.Cells(6, "E"), Sh2.Cells(Rows.Count, "E").End(xlUp)). _
Find(What:=c.Offset(0, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If FRange Is Nothing Then
Sh2.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(1, 10).Value = _
c.Resize(1, 10).Value
End If
Set Sh2 = Nothing
End If
Next
Set Sh1 = Nothing
End Sub

補足

改善しましたか(*^^*)有難うございます‼感謝です！
もう一点…品番が重複した場合削除してほしいのですが、コード追加して貰えますでしょうか？
(その場合、新しく追加された方のデータを削除)
どうかよろしくお願いしますm(__)m

回答No.7

kkkkkm

No6の追加です。
全てシート名は全角だとしたら(半角全角混在したら駄目です)
c.Text
のところを全て
StrConv(c.Text, vbWide)
にしてください。

補足

返信ありがとうございます(>_<)シート名はすべて半角としていますが、R1というシートも含まれています。その場合、StrConv(c.Text, vbWide)に修正したほうがいいですか？もうひとつ、データをC列６行目から貼付けられるように出来ますか？現在、二行目からデータの一部だけ反映されております。よろしくお願いします。

回答No.6

kkkkkm

> 試してみたところSet Sh2 = Sheets(c.Text)でデバッグがおきたのですが、何が原因なのでしょうか

シート名がセルに記載された1,2,3という半角ではなく全角の１、２、３(またはその逆)でしたらエラーになります。そのあたりはそちらでどちらかに合わせてください。

回答No.5

n-jun

エラーが起きた時はその場所もですがエラーの内容も必要。
仮にシート名を全角の数字にしているのなら指定しているのは半角の数字なので一致せずエラーは起きるでしょ。
シート名がどうなっているのかも重要な情報。
何が必要で何が不要かはBookを見られない回答者にしてみたら、何も判断できず質問者さんの正確無比な情報だけが頼りなのです。

回答No.4

n-jun

https://oshiete.goo.ne.jp/qa/11658168.html

既に解決されているのではなかったのでしょうか？

回答No.3

imogasi

すでに回答例はでているが、短いすっきりしたコードをめざして作った。
それだけに、全くの初心者には、やっていることがわかりにくいかも。
前もって下記「注意」を読んでおいてほしい。
ーー
データ例
Sheet1　A1:B12
営業所 販売
東京 20
仙台 34
川崎 32
東京 27
仙台 45
川崎 33
川崎 12
仙台 29
川崎 42
仙台 11
東京 17
--
標準モジュールに
ub test06()
branch = Array("東京", "川崎", "仙台")
For Each eigyo In branch '各営業所名で繰り返し処理
Range("A:A").AutoFilter '営業所名がある列でオートフィルタ
Worksheets("Sheet1").Range("A1").AutoFilter _
Field:=1, _
Criteria1:=eigyo, _
VisibleDropDown:=False
'---検索結果の出た範囲（コピー元範囲）から、見出し行分を除く
Worksheets("Sheet1").Range("A1").CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select '最上行の見出し１行だけを縮小
'--その時点での、その営業所シートの、A列データの最終行を割り出す
lr = Worksheets(eigyo).Range("A100000").End(xlUp).Row + 1
Selection.Copy Worksheets(eigyo).Range("A" & lr) '貼り付け先のアドレス指定して貼り付け
'--
Next
End Sub
ーー
実行後
「東京」シート
A2:B４
東京 20
東京 27
東京 17
他の営業所のデータ例の掲示は略。実行結果で見て。
ーーー
注意
１．Array("東京", "川崎", "仙台")の部分は、手作業で、自社実情で増やしたり、修正してください。
２．A列に出てくる営業所名と同じ名前のシート（当初白紙）を実行前に用意すること。
３．ただし、各シートでの第１行目の項目名（タイトル）は省略してあるので、手作業で入れてください。
４．毎月、Sheet1のデータが更新されたものができる場合、そのデータをSheet1に張り付けるか、別のシートに貼りつけて、その上記コードのWorksheets("Sheet1")
のSheet1を変えて、実行すること。
５．Sheet1が同じデータ（シート）のまま実行すると、同じ結果データが各営業所シートに下方向に累積してしまうので、注意のこと（やるな）。テストの場合は各営業所名シートは、クリアしておいて実行のこと。