No.1
- 回答日時:
こんばんは!
「総計」シートの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
No.2ベストアンサー
- 回答日時:
こんばんは、すでに回答は出ていますが、
違う方法で、
Sub Sample()
Dim myAry, key
Dim i As Long, j As Long, n As Long
For Each key In Array("エリア1", "エリア2", "エリア3", "エリア4", "エリア5")
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にデータを貼付けると各シートに振り分けしてくれる
何かと問題が起きそうなのでイベントでの実行は避けました。
ありがとうございます。完璧でした(*^▽^*)
ちなみに表の形式に変更があった場合、コードの変更箇所を教えていただくことはできますか?
お手数おかけしますがよろしくお願いいたします。
No.4
- 回答日時:
#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列)の重複を登録しない場合は、#2と追加コードで良いと思いますが、
重複№で他のC列、D列、E列何れかもしくはすべての値が違う場合は、古いデータと入れ替えるならば、
下記処理を追加します。
処理の流れで古い№行を削除する場合
#2の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があるので良いのかも知れません。
いろいろ想定し、アドバイス頂きありがとうございます(*^▽^*)
最初のコードが私が求めていたもので完璧でした!
素晴らしいです!!
実際に会社で使用するデータはもっと膨大な量であり、総計データを貼付けるセルの位置や
項目の数も変わってくるので、その場合どの部分を変更しなければならないのでしょうか?
質問ばかりすみませんm(__)m
No.5
- 回答日時:
>ちなみに表の形式に変更があった場合、コードの変更箇所を教えていただくことはできますか?
変更箇所がどうなるかによりますが、簡単な説明を(#2の場合)
’B列の探すキーワード(シート名と対になっている事)シート名を変更する場合は注意、
営業所が増える場合は、"エリア5","エリア6" カンマでつなげる。数値の場合注意、半角全角を分ける。シート名も同様にする。
For Each key In Array("エリア1", "エリア2", "エリア3", "エリア4", "エリア5")
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
配列の行方向列方向の表現は、便宜上です。
解説ありがとうございます。
とても分かりやすく変更しなければならない箇所を把握することが出来ましたm(__)m
実は、”エリア1”の部分、業務上のデータでは数値なので、シート名、総計表、コードを数値に変更してみたのですが
(すべて半角)振り分けしなくなってしまいました(>_<)!数値のみなのでコード上では””は外しました。
””をつけた場合も試しましたが反応しませんでした。
ほかに変更の必要な個所があるのでしょうか?
No.6
- 回答日時:
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
ありがとうございます(*^^*)
試してみたら下から5行目のソートの部分でデバッグ発生してしまいました!!
各シート二行目が項目行となっております。
なぜなのでしょうか(>_<)?
No.7
- 回答日時:
No.1・6です。
>ソートの部分でデバッグ発生してしまいました!!
ん~~~
そこでエラーになること自体が考えられないのですが、
各シートともすべて2行目の項目名は入っていますね?
万一Sheetになにもデータがない場合にエラーになることがあるかもしれませんが、
何とも理由が判りません。
※ こちらの手元のサンプルで確認後コードを記載しています。m(_ _)m
No.8
- 回答日時:
こんばんは、
>(すべて半角)振り分けしなくなってしまいました(>_<)!数値のみなのでコード上では””は外しました。
うん、、ちょっと処理には時間がかかるようなコードですが、、コード上を触らなくて良いようにしました。
(列などの指定は別)
図の営業所列にある値の種類がシート名で存在している場合に書き込まれるようにしました。
シート名にない場合エラーが発生しますが、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などを使用した方が良いかと、私は、サンプルを触った程度で理解していませんが
こちらより失礼いたします。先日は質問に解答いただき本当に有難うございました。再度、質問内容を修正し投稿しなおしたので、もし可能であればそちらよりご教授頂けないでしょうか。Qchan1962さんのコードが一番合っていたので…
No.9
- 回答日時:
#8です。
#9の訂正いたします。すみません不具合があります。
上から順に 上が誤り(#8) 下に差し替えてください。
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に書き出されると思います。
出来ましたぁ(´▽`)!
こちらのコードを使用したいと思います。ありがとうございます!泣
もう少しご教授よろしいでしょうか(>_<)
実際のデータでは、項目数が10個、総計表シートへ貼付ける位置はA1(1行目は項目名)、振り分け用シートにはA6からデータ挿入(5行目が項目)となります。その場合どこを変更すればいいですか?
何度も申し訳ないです(>_<)
No.10
- 回答日時:
総計表シート
>実際のデータでは、項目数が10個、
>ちなみに営業所の項目がA列に来ます
ReDim myAry(Application.CountIf(.Range("A:A"), Itemkey(ii)), 9)
For j = 0 To 9
などとなりますが、
A列に営業所の項目になるのであれば、
どう思うかと言われると、、、これは、問題です。
>そして、重複するコード№は消去させたいです。
コード№の列はどこですか?
これによってプロセスが変わります。 また、
総計表シートと振り分け用シートの列配置がご質問の場合、同じになっており、それに基づき
回答しております。その配置が一致しなくなるのであれば、プロセスを変更する事が必要になり
別質問などを建てる事を勧めます。
ここで、これ以上の変更に対する回答は、後からこのスレッドを参考にされる方の参考の妨げや、
いたずらに表題のご質問から離れる事にもなり、不適当と思われますので、悪しからず。
また、別に質問をされる場合、ご自身で学習し変更、改修が可能で無いのであれば、
実際に使用する仕様でご質問された方が良いです。さらに、改修が必要になる可能性を考え
処理を分けて質問するのが良いと思います。(場合によっては、改修し易くなり、理解もしやすいと思います。)
この度は親切に最後までアドバイス頂きありがとうございました。
分かりやすく素晴らしい対応でした!
質問を変えて再度スレを立てるのでまた都合が着くようであればよろしくお願いしますm(_ _)m
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 集計シートA列のコードと一致する右に並んだシート名(コード)の3行目から10行目をコピーして貼り付け 4 2022/08/18 15:24
- Excel(エクセル) VBA セルの値と同じ名前のシートにデータを貼り付けするやり方を教えてください 2 2022/05/17 16:26
- Visual Basic(VBA) 複数シートの複数列に入力されているデータを重複なしで抽出するVBAを作りたいです。 9 2022/06/17 10:33
- Visual Basic(VBA) エクセル VBA 処理スピードを上げたいのですが。 6 2023/03/31 20:52
- Excel(エクセル) VBAで、シート間の転記するコードを教えてください。 4 2023/03/26 10:43
- Visual Basic(VBA) Excel vbaについて知恵もしくは、コード教えて下さいm(__)m ① 表にあるデータをコピー、 2 2022/09/01 23:57
- Excel(エクセル) Excelマクロ 差分抽出の方法が知りたいです。 2 2023/03/07 13:25
- Visual Basic(VBA) コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーし 1 2022/08/29 23:46
- Visual Basic(VBA) 【VBA】Excelで罫線を引きたい 3 2022/07/14 12:04
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
このQ&Aを見た人はこんなQ&Aも見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
エクセル入力で項目別にシートに振り分ける方法を教えてください!
Excel(エクセル)
-
エクセルの1シートを項目別に別シートへ分ける方法
Excel(エクセル)
-
Excelで項目ごとにシートを振り分ける方法
Excel(エクセル)
-
-
4
Excelで条件別にシートを振り分ける方法
Excel(エクセル)
-
5
Excelの出納帳で、別シートに自動で振り分け
財務・会計・経理
-
6
エクセルで入力シートから別シートに蓄積方法について
Excel(エクセル)
-
7
VBAで繰り返しコピーしながら下へ移動させる方法
Excel(エクセル)
-
8
参照先のブックを開かずに内容をコピーしたい
Excel(エクセル)
-
9
エクセルVBA:表の内容を担当者別に振り分けたい
Access(アクセス)
-
10
Exel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について
Visual Basic(VBA)
-
11
vba 2つの条件が一致したらコピーして別シートに値のみ貼り付け
Visual Basic(VBA)
-
12
エクセル 関数で条件別で振り分ける方法
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
VBA 空白行に転記する
-
マクロ実行後に別シートの残像...
-
EXCELのSheet番号って変更でき...
-
VBA 実行時エラー1004 rangeメ...
-
グラフマクロで系列を変数にす...
-
VBA 別ブックからの転記の高速...
-
Unionでの他のシートの参照につ...
-
Excel2013で切り取り禁止
-
【Excel VBA】自動メール送信の...
-
【VBA】特定の条件でセルをコピー
-
ExcelのVBA ListBox.RowSource...
-
VBA Userformで一部別シートに...
-
Count Ifのセルの範囲指定に変...
-
アクセスからエクセルへ出力時...
-
ExcelのVBマクロを、バックグラ...
-
100万件越えCSVから条件を満た...
-
楽天RSSからエクセルVBAを使用...
-
Excel VBAで、散布図のデータ範...
-
VBA-重複データ同士の照合
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
VBA 空白行に転記する
-
EXCELのSheet番号って変更でき...
-
マクロ実行後に別シートの残像...
-
VBA 別ブックからの転記の高速...
-
VBA別シートの最終行の次行へ転...
-
【VBA】特定の条件でセルをコピー
-
Count Ifのセルの範囲指定に変...
-
100万件越えCSVから条件を満た...
-
楽天RSSからエクセルVBAを使用...
-
VBAコードについて
-
Changeイベントで複数セルへの...
-
VBAで変数の数/変数名を動的に...
-
Excel2013で切り取り禁止
-
グラフマクロで系列を変数にす...
-
VBA 実行時エラー1004 rangeメ...
-
ExcelのVBマクロを、バックグラ...
-
Unionでの他のシートの参照につ...
-
Excel VBA オートフィルターで...
-
アクセスからエクセルへ出力時...
おすすめ情報
ありがとうございます(*^-^*)
私の説明不足でわかりづらくてすみません!
重複データは最終行に追加するのではなく、新たに挿入したデータから削除となります。
その場合どのようになりますでしょうか?
返信お待ちしてますm(__)m
ちなみに営業所の項目がA列に来ます。よろしくお願いします(´Д⊂ヽ