マンガでよめる痔のこと・薬のこと

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

「VBA詳しい方、アドバイス願います!!」の質問画像

A 回答 (12件中1~10件)

おはようございます。


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

2行不要です。
データを書き込む処理
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)

列ナンバー(2)の数値を変えると列が変わります。
    • good
    • 1
この回答へのお礼

Qchan1962 様

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

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

No.12のお礼に対して。



ご期待を裏切ってしまい申し訳ないですが、わたくしボケジジィです。
    • good
    • 0
この回答へのお礼

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

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

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



Qchan1962様へ

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

なのでお気にせずにいて下さい。
    • good
    • 1
この回答へのお礼

めぐみん_様

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

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

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



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

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

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

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



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

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

以上。(別サイトで話が進んでいるようですからここで終了します。)
    • good
    • 1

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



データシートのA列がキーでC列の古い品番に重複しないデータのみをA列営業所別のシートに振り分け
C列からL列に書き込みます。
データシートの2行目からが、対象データ
振り分け先シートは、5行目に見出しがあらかじめ書かれている。
R1の様に半角全角が混在する場合があり、文字も数値のみも混在する。
半角全角問わず同じシートに書き込まれます。(これは、ちゃんと検証していません。多分です)
例  R1  R1 同じ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)とすると空白列が例にありましたので
埋まっているであろう範囲を選択しました。改修時は分かり難いかも知れません。
    • good
    • 0
この回答へのお礼

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

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

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



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

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

>.Open ThisWorkbook.FullName


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

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

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

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

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

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

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


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

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

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
    • good
    • 0
この回答へのお礼

めぐみん_さん、コードを考えて頂きありがとうございます。感謝しております(*^^*)試してみたところ
.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

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

    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング