こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

大変申し訳ございませんが、この投稿に添付された画像や動画などは、「BIGLOBEなんでも相談室」ではご覧いただくことができません。 OKWAVEよりご覧ください。

マルチメディア機能とは?

投稿日時 - 2020-05-27 07:07:14

QNo.9753653

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(12)

ANo.12

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

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

投稿日時 - 2020-05-28 06:37:23

ANo.11

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

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

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

投稿日時 - 2020-05-28 06:14:03

ANo.10

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

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

投稿日時 - 2020-05-27 22:31:05

補足

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

投稿日時 - 2020-05-27 23:01:43

ANo.9

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

投稿日時 - 2020-05-27 21:41:04

ANo.8

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

すみません、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

投稿日時 - 2020-05-27 20:37:17

補足

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

投稿日時 - 2020-05-27 21:54:34

ANo.7

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

投稿日時 - 2020-05-27 20:01:48

補足

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

投稿日時 - 2020-05-27 20:11:53

ANo.6

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

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

投稿日時 - 2020-05-27 19:34:11

ANo.5

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

投稿日時 - 2020-05-27 18:08:14

ANo.4

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

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

投稿日時 - 2020-05-27 15:04:20

ANo.3

すでに回答例はでているが、短いすっきりしたコードをめざして作った。
それだけに、全くの初心者には、やっていることがわかりにくいかも。
前もって下記「注意」を読んでおいてほしい。
ーー
データ例
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 '最上行の見出し1行だけを縮小
'--その時点での、その営業所シートの、A列データの最終行を割り出す
lr = Worksheets(eigyo).Range("A100000").End(xlUp).Row + 1
Selection.Copy Worksheets(eigyo).Range("A" & lr) '貼り付け先のアドレス指定して貼り付け
'--
Next
End Sub
ーー
実行後
「東京」シート
A2:B4
東京20
東京27
東京17
他の営業所のデータ例の掲示は略。実行結果で見て。
ーーー
注意
1.Array("東京", "川崎", "仙台")の部分は、手作業で、自社実情で増やしたり、修正してください。
2.A列に出てくる営業所名と同じ名前のシート(当初白紙)を実行前に用意すること。
3.ただし、各シートでの第1行目の項目名(タイトル)は省略してあるので、手作業で入れてください。
4.毎月、Sheet1のデータが更新されたものができる場合、そのデータをSheet1に張り付けるか、別のシートに貼りつけて、その上記コードのWorksheets("Sheet1")
のSheet1を変えて、実行すること。
5.Sheet1が同じデータ(シート)のまま実行すると、同じ結果データが各営業所シートに下方向に累積してしまうので、注意のこと(やるな)。テストの場合は各営業所名シートは、クリアしておいて実行のこと。

投稿日時 - 2020-05-27 12:37:44

ANo.2

> 品番が重複するデータが挿入された場合、新しいデータを削除

古いデータを残すということで、営業所のシートは作成済みとして以下のような感じでいかがですか。

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

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

投稿日時 - 2020-05-27 09:07:48

補足

コードを考えていただきありがとうございます。試してみたところSet Sh2 = Sheets(c.Text)でデバッグがおきたのですが、何が原因なのでしょうか(>_<)?

投稿日時 - 2020-05-27 17:32:21

ANo.1

>データシートA2にデータを貼付けると営業所ごとに各シートにデータを振分してほしいです。

営業所ごとにデータを取り出すコードを書く

>データシートは都度上書きとなりますが、振分用シートのデータは上書せずに、最後の行から挿入させたいです。

最後の行を見つけるコードを書く
そこにデータを追加するコードを書く

>品番が重複するデータが挿入された場合、新しいデータを削除。

重複品番がないか見つけるコードを書く
その行を覚えておき、そこを消すコードを書く

>振分用シートはすべて、5行目が項目行となります。

6行目から追加するコードを書く

投稿日時 - 2020-05-27 07:47:07

あなたにオススメの質問