【VBA】データを各シートに自動振り分けしたい

Question

VBA初級者です。
図の”総計”シートA3にデータを貼付けると各シートに振り分けしてくれるコードをアドバイス頂けますでしょうか((+_+))
総計シートのデータはA3から毎回上書きとなります。
ただ、各エリアシートのデータは消去せず最後尾から挿入されていくようにしたいのです。
そして、重複するコード№は消去させたいです。

どうぞよろしくお願いいたします。

Qchan1962 · Accepted Answer

こんばんは、すでに回答は出ていますが、
違う方法で、
Sub Sample()
Dim myAry, key
Dim i As Long, j As Long, n As Long
　　For Each key In Array("エリア１", "エリア２", "エリア３", "エリア４", "エリア５")
　　　　With Sheets("総計")
　　　　　　ReDim myAry(Application.CountIf(.Range("B:B"), key), 4)
　　　　　　n = 0
　　　　　　For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　　If key = .Cells(i, "B") Then
　　　　　　　　　　For j = 0 To 4
　　　　　　　　　　　　myAry(n, j) = .Cells(i, j + 1)
　　　　　　　　　　Next
　　　　　　　　　　n = n + 1
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　On Error Resume Next　’念のため
　　　　With Sheets(key)
　　　　　　.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A").Resize(UBound(myAry), 5) = myAry
　　　　　　.Range("A1:E" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates (1)
　　　　End With
　　Next
End Sub

＞図の”総計”シートA3にデータを貼付けると各シートに振り分けしてくれる
何かと問題が起きそうなのでイベントでの実行は避けました。

Qchan1962 · Answer

総計表シート
＞実際のデータでは、項目数が10個、
＞ちなみに営業所の項目がA列に来ます
ReDim myAry(Application.CountIf(.Range("A:A"), Itemkey(ii)), 9)
For j = 0 To 9
などとなりますが、

A列に営業所の項目になるのであれば、
どう思うかと言われると、、、これは、問題です。

＞そして、重複するコード№は消去させたいです。

コード№の列はどこですか？

これによってプロセスが変わります。　また、
総計表シートと振り分け用シートの列配置がご質問の場合、同じになっており、それに基づき
回答しております。その配置が一致しなくなるのであれば、プロセスを変更する事が必要になり
別質問などを建てる事を勧めます。
ここで、これ以上の変更に対する回答は、後からこのスレッドを参考にされる方の参考の妨げや、
いたずらに表題のご質問から離れる事にもなり、不適当と思われますので、悪しからず。

また、別に質問をされる場合、ご自身で学習し変更、改修が可能で無いのであれば、
実際に使用する仕様でご質問された方が良いです。さらに、改修が必要になる可能性を考え
処理を分けて質問するのが良いと思います。（場合によっては、改修し易くなり、理解もしやすいと思います。）

Qchan1962 · Answer

＃８です。
＃９の訂正いたします。すみません不具合があります。
上から順に　上が誤り（＃８）　下に差し替えてください。

Key_list.Add .Cells(i, "B").Value, CStr(.Cells(i, "B").Value)
Key_list.Add .Cells(i, "B").Value, StrConv(CStr(.Cells(i, "B").Value), vbWide)

Itemkey(ii) = .Cells(i, "B").Value
Itemkey(ii) = StrConv(.Cells(i, "B").Value, vbWide)

If Itemkey(ii) = .Cells(i, "B") Then
If Itemkey(ii) = StrConv(CStr(.Cells(i, "B")), vbWide) Then

以上です。

数字の1も文字1も同じシート1に書き出されると思います。

Qchan1962 · Answer

こんばんは、
>(すべて半角)振り分けしなくなってしまいました(>_<)！数値のみなのでコード上では””は外しました。

うん、、ちょっと処理には時間がかかるようなコードですが、、コード上を触らなくて良いようにしました。
（列などの指定は別）

図の営業所列にある値の種類がシート名で存在している場合に書き込まれるようにしました。
シート名にない場合エラーが発生しますが、On Error Resume Nextで飛ばしています。

今度の条件は、B列の各値がシート名と一致している
A列が一意の№
A2セルには見出しなどの値がある事（データは3行目から）
出力は、A～E列
B列の値の設定は必要ありませんが、対応するシートが必要です。

上手く行きますでしょうか？

Sub Sample3()
Dim Key_list As New Collection
Dim myAry, Sht, Itemkey()
Dim i As Long, j As Long, n As Long, ii As Long
　　With Sheets("総計")
　　　　For i = 3 To .Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　ReDim Preserve Itemkey(ii)
　　　　　　On Error Resume Next
　　　　　　Key_list.Add .Cells(i, "B").Value, CStr(.Cells(i, "B").Value)
　　　　　　If Err.Number = 0 Then
　　　　　　　　Itemkey(ii) = .Cells(i, "B").Value
　　　　　　　　ii = ii + 1
　　　　　　End If
　　　　　　On Error GoTo 0
　　　　Next
　　End With
　　For ii = 0 To UBound(Itemkey)
　　　　With Sheets("総計")
　　　　　　ReDim myAry(Application.CountIf(.Range("B:B"), Itemkey(ii)), 4) '4はE列
　　　　　　n = 0
　　　　　　For i = 3 To .Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　　　If Itemkey(ii) = .Cells(i, "B") Then
　　　　　　　　　　For j = 0 To 4
　　　　　　　　　　　　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, "A").End(xlUp).Offset(1).Resize(UBound(myAry), 5) = myAry
　　　　　　　　　　　　.Range("A2").CurrentRegion.RemoveDuplicates (1)
　　　　　　　　　　　　.Range("A2").CurrentRegion.Sort key1:=.Columns("A"), Order1:=xlAscending, Header:=xlYes
　　　　　　　　　　End With
　　　　　　　　　　GoTo nx
　　　　　　　　End If
　　　　　　Next
　　　　Next
nx:
　　Next
End Sub

処理時間が気になります。限定的にした方が当然早いと思いますし、
データが多い場合、ADOなどを使用した方が良いかと、私は、サンプルを触った程度で理解していませんが

tom04 · Answer

No.1・6です。

＞ソートの部分でデバッグ発生してしまいました！！

ん～～～
そこでエラーになること自体が考えられないのですが、
各シートともすべて2行目の項目名は入っていますね？

万一Sheetになにもデータがない場合にエラーになることがあるかもしれませんが、
何とも理由が判りません。

※　こちらの手元のサンプルで確認後コードを記載しています。m(_ _)m

tom04 · Answer

No.1です。

補足を拝見しました。
結局各シートに「総計」シートのA列データがあった場合、B列～E列データを差し替えればよい！というコトですかね。
↓のコードにしてみてください。

Sub Sample2()
　Dim i As Long
　Dim c As Range
　Dim sN As String
　Dim wS As Worksheet

With Worksheets("総計")
　　　For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　sN = .Cells(i, "B")
　　　　　Set wS = Worksheets(sN)
　　　　　Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　If Not c Is Nothing Then
　　　　　　　wS.Cells(c.Row, "B").Resize(, 4).Value = .Cells(i, "B").Resize(, 4).Value
　　　　　　Else
　　　　　　　wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = _
　　　　　　　　　.Cells(i, "A").Resize(, 5).Value
　　　　　　End If
　　　Next i
　　End With
    
　　'//▼各シート、並び替え//
　　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　.Range("A2").CurrentRegion.Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlYes   '//←2行目が項目行だという前提//
　　　　End With
　　　Next i
　　　　MsgBox "完了"
End Sub

※　コード内にコメントを入れていますが、
各シートとも2行目が項目行だという前提です。m(_ _)m

Qchan1962 · Answer

＞ちなみに表の形式に変更があった場合、コードの変更箇所を教えていただくことはできますか？
変更箇所がどうなるかによりますが、簡単な説明を（＃２の場合）

’B列の探すキーワード（シート名と対になっている事）シート名を変更する場合は注意、
営業所が増える場合は、"エリア５","エリア6" カンマでつなげる。数値の場合注意、半角全角を分ける。シート名も同様にする。
　　For Each key In Array("エリア１", "エリア２", "エリア３", "エリア４", "エリア５")

With Sheets("総計")
配列の大きさを設定しています。
Application.CountIf(.Range("B:B"), key)　B列にkeyがいくつあるか抽出して配列の行方向の大きさを決めています。
対象列が変わる場合　B:Bを変更、4は列方向の大きさ、4はE列（0～4なので）5ならF列も対象になります。

ReDim myAry(Application.CountIf(.Range("B:B"), key), 4)　
　　　　　　n = 0
　　　　　　For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row　’№のある列にする　(Rows.Count, 1)はA列 1を"A"の様に書いても良い
 .Cells(i, "B") Thenは、key（営業所）の列、B列より前に列を追加した場合変更
　　　　　　　　If key = .Cells(i, "B") Then
　　　　　　　　　　For j = 0 To 4　配列の列方向の場所に書きこみ　4はE列（0～4なので）
　　　　　　　　　　　　myAry(n, j) = .Cells(i, j + 1)
　　　　　　　　　　Next
　　　　　　　　　　n = n + 1
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　On Error Resume Next　’念のため
　　　　With Sheets(key)
　　　　　.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(myAry), 5) = myAry
　　　　　.Range("A2").CurrentRegion.RemoveDuplicates (1)　’全く同じものはここで消える
　　　　End With
　　Next
End Sub

配列の行方向列方向の表現は、便宜上です。

Qchan1962 · Answer

#2です。
よく見ると各エリアシートは、昇順に並んでいるようですね。
総計シートにもソートをかけた方が処理は早く出来そうですが、、取り敢えずそこは触らずに
下記の部分を追加します。（A2セルには見出しデータがある場合）

.Range("A1:E" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates (1)
’ここに
　　　　　　.Range("A2").CurrentRegion.Sort key1:=.Columns("A"), Order1:=xlAscending, Header:=xlYes
’を追加
　　　　End With
　　Next
End Sub

重複№（A列）の重複を登録しない場合は、＃２と追加コードで良いと思いますが、
重複№で他のC列、D列、E列何れかもしくはすべての値が違う場合は、古いデータと入れ替えるならば、
下記処理を追加します。

処理の流れで古い№行を削除する場合
＃２のWith Sheets(key)以下を下記の様に変え

With Sheets(key)
　　.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(myAry), 5) = myAry
　　.Range("A2").CurrentRegion.RemoveDuplicates (Array(1, 3, 4, 5))　’全く同じものはここで消える
　Call OldKey_Delete(key)
　　.Range("A2").CurrentRegion.Sort key1:=.Columns("A"), Order1:=xlAscending, Header:=xlYes
　End With

新たに下記プロシージャを追加。（流れ的に若い行にあるものが古い場合の削除）

Sub OldKey_Delete(sName)
Dim Rng As Range, uCell As Range
Dim oKey As String, nKey As String, oName As String, nName As String
Dim n As Long
　　For Each Rng In Sheets(sName).Range("A3:A" & Sheets(sName).Cells(Rows.Count, "A").End(xlUp).Row)
　　　　oKey = Rng.Value
　　　　oName = Rng.Offset(0, 1).Value
　　　　Do While Rng.Offset(1 + n, 0) <> ""
　　　　　　nKey = Rng.Offset(1 + n, 0).Value
　　　　　　nName = Rng.Offset(1 + n, 1).Value
　　　　　　If oKey = nKey And oName = nName Then
　　　　　　　　If uCell Is Nothing Then
　　　　　　　　　　Set uCell = Rng
　　　　　　　　Else
　　　　　　　　　　Set uCell = Union(uCell, Rng)
　　　　　　　　End If
　　　　　　End If
　　　　　　n = n + 1
　　　　Loop
　　　　n = 0
　　Next
　　If Not uCell Is Nothing Then
　　　　uCell.EntireRow.Delete
　　End If
End Sub

一例として示しましたが、
コード№から推測するとデータ数も多くあるようなので、、
ADODB.Recordsetなどを使用した方がFilterやSortがあるので良いのかも知れません。

めぐみん_ · Answer

＞そして、重複するコード№は消去させたいです。

これって既出のデータを消去なのか追加データを追加しないって事なのか？？？

tom04 · Answer

こんばんは！

「総計」シートのB列に出現するシート名はすべて存在する！という前提です。
＞そして、重複するコード№は消去させたいです。
とは、各シートにすでにA列のコードがある場合、
その行のデータを削除して新たに最終行以降に追加する！というコトですね。

標準モジュールにしてください。

Sub Sample1()
　Dim i As Long
　Dim c As Range
　Dim sN As String
　Dim wS As Worksheet
  
　　With Worksheets("総計")
　　　For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　sN = .Cells(i, "B")
　　　　　Set wS = Worksheets(sN)
　　　　　Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　If Not c Is Nothing Then
　　　　　　　wS.Cells(c.Row, "A").Resize(, 5).Delete shift:=xlUp
　　　　　　End If
　　　　　wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = .Cells(i, "A").Resize(, 5).Value
　　　Next i
　　End With
End Sub

こんな感じではどうでしょうか。m(_ _)m

【VBA】データを各シートに自動振り分けしたい

こんばんは、すでに回答は出ていますが、

総計表シート

＃８です。

こんばんは、

No.1・6です。

No.1です。

＞ちなみに表の形式に変更があった場合、コードの変更箇所を教えていただくことはできますか？

#2です。

＞そして、重複するコード№は消去させたいです。

こんばんは！

似たような質問が見つかりました

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

関連するカテゴリからQ&Aを探す

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

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング