VBA詳しい方、アドバイス願います!!

「データ」シートA1に張り付けられたデータを”営業所””ごとにそれぞれのシートに自動で振分してくれるマクロを作りたいのです。データは都度貼り替えますが、振分シートのデータは削除せず、最後尾の行へ新しいデータを挿入させていくようにしたいです。”品番”が重複するデータが挿入された場合、新しいデータから重複データを削除とします。振分シートはすべてC6から貼付けになり、5行目は項目行となります。どのようなコードを作成すればよいか、ご教授願います。

No.9 ベストアンサー 回答者： Qchan1962 回答日時： 2020/05/28 07:57

おはようございます。

＃８です。
自身の回答を何気に読んでいたら、、、わけのわからん処理がありました。
コピペで改造したのが原因で、申し訳ないです。
下記を訂正いたします。。

２行不要です。
データを書き込む処理
For i = 0 To UBound(Itemkey)不要ですので削除
For i　ループの中で変数　i　が使用されていない事でも不要な処理でした。
それに対するNext（nx:の上の行）も削除してください。

ここまで書いて、気が付きました。半角全角の処理で、、
文字列が半角+全角や半角+全角+半角など、、、
Application.CountIfでは、対応できませんね。。
Itemkeyの配列に入れている文字列なので、
範囲内の一致する文字列で半角全角に対応する関数
WorksheetFunction.SumProduct,,、いけないか？たぶんレンジ
Functionを作成した方がわかり易いかも、と思いますが、他の良い方法ご存知の方、教えてください。
総当たりで配列内で数を取得します。
多分、配列の大きさもリスト作成時に取得設定できると思いますが、朝で頭が回りません。

改めて、プロシージャ挙げます。
ちなみに、営業所名、シート名にルールを決めて半角全角を混在させないで、
名簿シートなどに書き出してあればこの苦労は、無いかも知れません。
私は、むしろ、趣味なので良いのですが、、、。

Sub Sample()
Dim Key_list As New Collection
Dim myAry, Sht, KeyItem
Dim i As Long, j As Long, n As Long, ii As Long, ix As Long
Dim dataWs As Worksheet
Dim tmpAry, x As Long
　　Set dataWs = Worksheets("データ")　 'ご質問のシート名「データ」シート
　　tmpAry = dataWs.Range("A2:A" & dataWs.Cells(Rows.Count, "A").End(xlUp).Row)
　　With dataWs
　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　On Error Resume Next
　　　　　　Key_list.Add StrConv(UCase(.Cells(i, "A").Text), vbWide), StrConv(UCase(.Cells(i, "A").Text), vbWide)　　'営業所名でリストを作ります
　　　　　　On Error GoTo 0
　　　　Next
　　End With
　　For Each KeyItem In Key_list　　'リスト内
　　　　With dataWs
　　　　　　ix = 0
　　　　　　For x = 1 To UBound(tmpAry)　　'配列のサイズを調べる
　　　　　　　　If KeyItem = StrConv(UCase(tmpAry(x, 1)), vbWide) Then
　　　　　　　　　　ix = ix + 1
　　　　　　　　End If
　　　　　　Next
　　　　　　ReDim myAry(ix, 9)　　'9=0~9なので10列目まで
　　　　　　n = 0
　　　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　If KeyItem = StrConv(UCase(.Cells(i, "A")), vbWide) Then
　　　　　　　　　　For j = 0 To 9
　　　　　　　　　　　　myAry(n, j) = .Cells(i, j + 1)
　　　　　　　　　　Next
　　　　　　　　　　n = n + 1
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　On Error Resume Next
　　　　For Each Sht In Worksheets
　　　　　　If StrConv(UCase(Sht.Name), vbWide) = KeyItem Then
　　　　　　　　With Sheets(Sht.Name)
　　　　　　　　　　If Sht <> dataWs Then
　　　　　　　　　　　　.Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(UBound(myAry), 10) = myAry　　'出力
　　　　　　　　　　　　.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
　　　　　　　　　　　　.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).Sort key1:=.Columns(4), Order1:=xlAscending
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　　　GoTo nx
　　　　　　End If
　　　　Next
nx:
　　Next
　　Set dataWs = Nothing
　　MsgBox ("完了")
End Sub

リストの作り方や問題点を変えましたが、ご希望の結果になりますでしょうか？

重複データを削除しているコードです
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)

列ナンバー（２）の数値を変えると列が変わります。

この回答へのお礼

Qchan1962　様

この度はわたしの我儘にお付き合い頂き有難うございました(*^^*)
無事解決いたしました。対応も素晴らしくお二方には感謝しかありません。
VBAが趣味だなんて羨ましい限りです‼
今回の件、大変ご迷惑おかけいたしました(>_<)＆有難うございました。
ベストアンサーに選ばせてください。

お礼日時：2020/05/28 19:50

No.13 回答者： めぐみん_ 回答日時： 2020/05/28 18:30

No.12のお礼に対して。

ご期待を裏切ってしまい申し訳ないですが、わたくしボケジジィです。

この回答へのお礼

そうなのですね！笑笑
全くボケておられませんよ‼
どちらにせよ尊敬いたします。(私は挫折したので…）
最後までお付き合いくださり有難うございました(*^^*)

お礼日時：2020/05/28 19:26

No.12 回答者： めぐみん_ 回答日時： 2020/05/28 12:52

直接の回答ではありません事お詫びします。

Qchan1962様へ

私は決してあなた様の参加に気分を害したとかは全くありません。
参加については自由なはずです。
単に
・別サイトで問題解決が進んでいる
・私の回答した内容はあくまでも営業所列は数値（シート名は数字）のみで作成したので、数値と文字列が混同しているのなら使えないな
と言う事での退散です。

なのでお気にせずにいて下さい。

この回答へのお礼

めぐみん_様

この度は、前スレッドよりお付き合い頂き有難うございます。
無事問題解決いたしました。
気分を害されるような対応をしてしまっていたら大変申し訳ありませんでした。
お二方によりアドバイス頂いた解答を今後共業務に生かしていきたいと思います。
女性でプログラムを組めること、とても素晴らしく尊敬します。
ありがとうございました(*^^*)

お礼日時：2020/05/28 18:25

No.11 回答者： Qchan1962 回答日時： 2020/05/28 12:23

質問者様、スレッドお借りしてすみません。

#10 めぐみん_様　へ　横から突然大変失礼をいたしました。

先の　https://oshiete.goo.ne.jp/qa/11658168.html　のご質問の
＃８に寄せられたお礼で、こちらのスレッドを拝見し、回答しました。
先の質問後半での流れで、推測して回答を投稿した次第です。本スレッドの流れを
把握せず、いきなり回答投稿をして気分を害されたと思います。

誠に申し訳ございませんでした。

No.10 回答者： めぐみん_ 回答日時： 2020/05/28 09:00

No.4に対しての回答もなくNo.5のコードを提示しましたが、

＞シート名はすべて半角としていますが、R1というシートも含まれています。

と別サイトでは補足があったようで、そうなるとNo.5のコードは使えません。

以上。（別サイトで話が進んでいるようですからここで終了します。）

No.8 回答者： Qchan1962 回答日時： 2020/05/28 00:48

こんばんは、気が付きませんでした。

データシートのA列がキーでC列の古い品番に重複しないデータのみをA列営業所別のシートに振り分け
C列からL列に書き込みます。
データシートの２行目からが、対象データ
振り分け先シートは、５行目に見出しがあらかじめ書かれている。
R1の様に半角全角が混在する場合があり、文字も数値のみも混在する。
半角全角問わず同じシートに書き込まれます。（これは、ちゃんと検証していません。多分です）
例 　R1　 R１　同じR1シートへ

営業所名と同じ名前のシートがある事、シートが無い場合は書き込みされません。

余談ですが、 めぐみん_さんの構文の方がデータが多くある場合、とても速いですよ。（現在学習中）
＞.Open ThisWorkbook.FullName
＞でデバッグとなったのですが、何が原因なのでしょうか(>_<)
これ、テスト的に作成した新規ブックを保存していなかったのではないでしょうか？
.FullName　なのでパスも含まれるかと思いますので。

Sub Sample()
Dim Key_list As New Collection
Dim myAry, Sht, Itemkey()
Dim i As Long, j As Long, n As Long, ii As Long
Dim dataWs As Worksheet: Set dataWs = Worksheets("データ")
　　With dataWs
　　　　For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　ReDim Preserve Itemkey(ii)
　　　　　　On Error Resume Next
　　　　　　Key_list.Add StrConv(.Cells(i, "A").Text, vbWide), StrConv(.Cells(i, "A").Text, vbWide)
　　　　　　If Err.Number = 0 Then
　　　　　　　　Itemkey(ii) = .Cells(i, "A")　’営業所名でリストを作ります
　　　　　　　　ii = ii + 1
　　　　　　End If
　　　　　　On Error GoTo 0
　　　　Next
　　End With
　　For ii = 0 To UBound(Itemkey)
　　　　With dataWs
　　　　　　ReDim myAry(Application.CountIf(.Range("A:A"), Itemkey(ii)), 9)　　'9=0~9なので10列目まで
　　　　　　n = 0
　　　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　If StrConv(UCase(Itemkey(ii)), vbWide) = StrConv(UCase(.Cells(i, "A")), vbWide) Then
　　　　　　　　　　For j = 0 To 9
　　　　　　　　　　　　myAry(n, j) = .Cells(i, j + 1)
　　　　　　　　　　Next
　　　　　　　　　　n = n + 1
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　On Error Resume Next
　　　　For i = 0 To UBound(Itemkey)
　　　　　　For Each Sht In Worksheets
　　　　　　　　If StrConv(Sht.Name, vbWide) = StrConv(Itemkey(ii), vbWide) Then
　　　　　　　　　　With Sheets(Sht.Name)
　　　　　　　　　　　　.Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(UBound(myAry), 10) = myAry
　　　　　　　　　　　　.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
　　　　　　　　　　　　.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).Sort key1:=.Columns(3), Order1:=xlAscending
　　　　　　　　　　End With
　　　　　　　　　　GoTo nx
　　　　　　　　End If
　　　　　　Next
　　　　Next
nx:
　　Next
　　Set dataWs = Nothing
　　MsgBox ("完了")
End Sub


.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
変な書き方ですが、.Range("C6").CurrentRegion.RemoveDuplicates (2)とすると空白列が例にありましたので
埋まっているであろう範囲を選択しました。改修時は分かり難いかも知れません。

この回答へのお礼

コード作成頂き有難うございます‼感謝いたします。
試してみたところ、デバッグもなくスムーズに完了まで進むことが出来ました。ただ、品番が重複してるデータも追加されるのですが、改善できますでしょうか(>_<)
前回のスレッドよりお付き合いいただき申しわけありません。。
私のパソコンではめぐみんさんのコードにデバッグが発生しまうので、(保存場所が悪いのか？)会社の方でも双方のコードを使用し試してみたいと思います。

お礼日時：2020/05/28 06:46

No.7 回答者： めぐみん_ 回答日時： 2020/05/27 21:50

ちなみに過去にこの方法での回答は何度かしてますが、

＞.Open ThisWorkbook.FullName
＞でデバッグとなったのですが、何が原因なのでしょうか(>_<)

というのは初めて見ました。
もしMac等Win以外でやっているってなら私は未経験なので解決策は不明ですよ。

No.6 回答者： めぐみん_ 回答日時： 2020/05/27 19:39

＞.Open ThisWorkbook.FullName

＞でデバッグとなったのですが、何が原因なのでしょうか(>_<)

そこは単純にワークブックのPath及び名前を繋げた物を得ているだけです。
なのでもしかするとアクセス出来ない（権限がない）所に保存しているのかもですね。
ＣドライブであればＤドライブとかにしてみるか？

私はデスクトップに保存して試しましたから他に言えるとしたらフォルダ名に全角文字を使っているからかな？
それも保存先を変更して検証してください。

保存先を変えてもコードの変更は今ある情報からの判断では問題ないかと。

＞のコードはそのまま使用してよかったでしょうか？
＞初心者のため、何もわからず申し訳ないです、、

私もただの初級者ですが、良いかどうかはこちらではわかりません。
あくまでも情報を基にしているのであって、それ以上の事はこちらでは検証できないからです。

No.5 回答者： めぐみん_ 回答日時： 2020/05/27 08:53

・個々の営業所のシート名は『営業所』の列に合わせた半角数字で成り立っている事。

・個々の営業所のＣ５より左にデータが存在しない事。（罫線があるのはきになるけど）

最初に『品番』が同じデータは省いてしまう方が楽でしょ。
且つ営業所の数値がシート名の数字と一致しているデータを抽出して貼り付ける。

Sub megu()
Dim objCn As Object
Dim objRS As Object
Dim ws As Worksheet
Dim strSQL As String
Dim r As Range
Dim i As Integer

Set objCn = CreateObject("ADODB.Connection")
Set objRS = CreateObject("ADODB.Recordset")

With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=YES"
.Open ThisWorkbook.FullName
End With

For i = 2 To Worksheets.Count '★ 一番左がデータシートだとして

Set ws = Worksheets(i)

With ws

Set r = .Range("C5").CurrentRegion

strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM [データ$]"
strSQL = strSQL & " WHERE [営業所] = " & Val(ws.Name) '★ シート名は半角数字である事
strSQL = strSQL & " AND NOT ([品番] IN"
strSQL = strSQL & " (SELECT 品番"
strSQL = strSQL & " FROM [" & ws.Name & "$" & r.Address(0, 0) & "]));"

Set objRS = objCn.Execute(strSQL)

r.Offset(r.Rows.Count).Resize(1, 1).CopyFromRecordset objRS
Set r = Nothing

objRS.Close

End With

Set ws = Nothing
Next

objCn.Close

Set objCn = Nothing
Set objRS = Nothing

End Sub

この回答へのお礼

めぐみん_さん、コードを考えて頂きありがとうございます。感謝しております(*^^*)試してみたところ
.Open ThisWorkbook.FullName
でデバッグとなったのですが、何が原因なのでしょうか(>_<)
ちなみに、strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM [データ$]"
strSQL = strSQL & " WHERE [営業所] = " & Val(ws.Name) '★ シート名は半角数字である事
strSQL = strSQL & " AND NOT ([品番] IN"
strSQL = strSQL & " (SELECT 品番"
strSQL = strSQL & " FROM [" & ws.Name & "$" & r.Address(0, 0) & "]));"
のコードはそのまま使用してよかったでしょうか？
初心者のため、何もわからず申し訳ないです、、

お礼日時：2020/05/27 19:23

No.4 回答者： めぐみん_ 回答日時： 2020/05/26 22:23

営業所の列に『R1』とありますけど、実際は数値のみなのですか？それとも文字列との混合？