[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一覧に存在しないデータの抽出』（もも）
以前質問させていただきました。
そもそもでデータの入力方法を変更すれば解決する問題なのですが。。。
一覧
A B
1 aaa 12000
AAA
ａａａ
株式会社aaa
↑1セルに入力されています
データ
A ・・・ E 1 aaa 1000 2 AAA 2000 3 ａａａ 3000 4 株式会社aaa 6000 5 株式会社ａａａ 10000
B1セルには
=SUMPRODUCT((COUNTIF(A1,"*"データA$1:A$1600&"*"))*(データ!E$1:E$1600<>""),データ!E$1:E$1600)
と入力しています。
この時にデータの5行目の「株式会社ａａａ」が集計漏れしているので、漏れてしまっているデータを抽出したいと思っております。
(想定としてはG1から表示)
B1の集計も含めたマクロor集計漏れ抽出のみだけでも行いたいです。
よろしくお願いします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
Dim dic As Object, dic2 As Object, k As Variant, c As Range, i As Long, tot As Long
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For Each c In Sheets("データ").Range("A:A").SpecialCells(2)
dic(c.Value) = dic(c.Value) + Val(c.Offset(, 1).Value)
dic2(c.Value) = 1
Next c
For i = 0 To UBound(Split(Sheets("一覧").Range("A1").Value, Chr(10)))
tot = tot + dic(Split(Sheets("一覧").Range("A1").Value, Chr(10))(i))
dic2(Split(Sheets("一覧").Range("A1").Value, Chr(10))(i)) = 0
Next i
Sheets("一覧").Range("B1").Value = tot
For Each k In dic2
If dic2(k) = 1 Then MsgBox k & "が漏れてます。"
Next k
End Sub
（mm） 2019/03/13(水) 17:13
漏れていないデータも表示されてしまいます。。。
（もも） 2019/03/13(水) 18:09
とりあえず、ワイルドカードは考えず、「データ」シートのA列にあるけど、「一覧」シートのB列に無いものを抽出するだけの例を書きます。
Sub test()
Dim AR As Object
Dim i As Long
Set AR = CreateObject("System.Collections.ArrayList")
With Sheets("データ")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If AR.Contains(.Cells(i, "A").Value) = False Then
AR.Add .Cells(i, "A").Value
End If
Next i
End With
With Sheets("一覧")
For i = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row
If AR.Contains(.Cells(i, "B").Value) = True Then
AR.Remove .Cells(i, "B").Value
End If
Next i
If 0 < AR.Count Then
.Range("G1").Resize(AR.Count, 1).Value = WorksheetFunction.Transpose(AR.toarray)
Else
MsgBox "漏れなし", vbInformation
End If
End With
End Sub
（???） 2019/03/13(水) 18:36
＞大部分が漏れていますと表示されます
1600行のデータがあるとすると、一覧のA1には４個しかないのだから、
1596行分のデータが漏れていますとなるのでしょうか？
＞一覧の方がA列B列ではなく、
一覧のA2やA3にも別のデータが続くのでしょうか？
それとも、A1だけですか。
（マナ） 2019/03/13(水) 20:03
こういうことでしょうか。
Option Explicit
Sub test()
Dim dic As Object
Dim al As Object, al2 As Object
Dim c As Range
Dim s As String
Dim e
Dim tmp As Long
Set dic = CreateObject("scripting.dictionary")
Set al = CreateObject("system.collections.arraylist")
For Each c In Sheets("データ").Columns("A").SpecialCells(2)
s = c.Value
dic(s) = dic(s) + c.Offset(, 4).Value
If Not al.contains(s) Then al.Add s
Next
For Each c In Sheets("一覧").Columns("B").SpecialCells(2)
Set al2 = al.Clone
tmp = 0
For Each e In Split(c.Value, vbLf)
tmp = tmp + dic(e)
al2.Remove e
Next
c.Offset(, 1).Value = tmp
If al2.Count > 0 Then
c.Offset(, 5).Resize(, al2.Count).Value = al2.toarray
End If
Next
End Sub
（マナ） 2019/03/13(水) 21:22
（マナ） 2019/03/13(水) 21:27
（マナ） 2019/03/13(水) 21:33
＞一覧 ＞ A B ＞ 1 aaa 12000 ＞ AAA ＞ ａａａ ＞ 株式会社aaa ＞ ↑1セルに入力されています ＞ ＞データ ＞ A ・・・ E ＞1 aaa 1000 ＞2 AAA 2000 ＞3 ａａａ 3000 ＞4 株式会社aaa 6000 ＞5 株式会社ａａａ 10000
掲示されたサンプルデータは不適切な気がします。(いい加減なデータと言った方が近い）
集計漏れが話題になっていますが、それは集計対象になっているものの裏返しですよね？
だとすると、まず、集計対象になっている会社は何であり、集計結果は何円が正しいのですか？ それをまず示してください。
※簡単に説明しようとして、いい加減なサンプルを使うと、却って理解しにくくなります。
（半平太） 2019/03/13(水) 23:47
A B ・・・ K
1 会社名 検索用会社名 ・・・ 金額
2 田中製造所 田中製造所 ・・・ 12000
TANAKA
ﾀﾅｶ
伊勢三重
3 佐藤製鉄所 佐藤製鉄所 ・・・ 8000
SATO
静岡富士
・
・
・
60 東洋株式会社 東洋株式会社 ・・・ 9000
TOYO
東洋山梨
東洋名古屋
データのシートは
A ・・・ E
1 田中 5000
2 東洋 2000
3 SATO 4000
4 東洋山梨 3000
5 TANAKA 5000
6 佐藤 2000
7 たなか 4000 ←
8 ﾄｰﾖｰ 2000
9 伊勢三重 2000
10 静岡富士 8000
11 さとう 7000 ←
12 東洋株式会社 4000
・
・
・
1200 ﾄｰﾖｰ 1000 ←
となっています。
集計結果は
【誤】 【正】
田中製造所 12000 16000
佐藤製鉄所 8000 15000
東洋株式会社 9000 10000
となってほしいです。
回答になっていますでしょうか
（もも） 2019/03/14(木) 09:25
＞回答になっていますでしょうか
詳細は見ていませんが、キッチリしていてすばらしいです。
※ちょっと前までは、危なっかしい処理だなと思っていたのですが、 結構しっかりしているので安心しました。
処理手順としては、以下のツーステップになると思います。
(1)検索用会社名に該当しないデータの有無を確認する(プログラムで洗い出す） 有ったら、該当する会社の検索法会社名に追加する(これは手作業）。
(2)全ての追加が終わったら、普通にプログラムで集計する。
今日はちょっと忙しいので戻るのが遅くなります。
それまでに他の回答者からレスが付くといいですね。
（半平太） 2019/03/14(木) 10:06
最後の正誤表は間違っていませんか？
私の結果は違っていますし、正誤表は手作業でないと判断できないでしょう...
集計結果を一覧シートのK列、データシートのG列に集計漏れのマークを記入。
ということで、
Sub test()
Dim a, b, i As Long, ii As Long, myRow As Long, temp, mySum As Double
With Sheets("データ")
a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 5).Value
With Sheets("一覧")
b = .Range("a1", .Cells.SpecialCells(11)).Resize(, 3).Value
b(1, 1) = "金額"
For i = 2 To UBound(b, 1)
If ((b(i, 1) <> "") * (b(i, 1) <> temp)) Then
If myRow > 0 Then b(myRow, 1) = mySum
myRow = i: mySum = 0: b(i, 1) = 0
End If
If b(i, 2) <> "" Then
For ii = 1 To UBound(a, 1)
If (b(i, 2) Like a(ii, 1) & "*") * (a(ii, 5) <> Chr(2)) Then
mySum = mySum + a(ii, 5): a(ii, 5) = Chr(2)
End If
Next
End If
If i = UBound(b, 1) Then b(myRow, 1) = mySum
Next
.Range("k1").Resize(UBound(b, 1)).Value = b
End With
ReDim b(1 To UBound(a, 1), 1 To 1): b(1, 1) = "集計漏れ"
For i = 1 To UBound(a, 1)
If a(i, 5) <> Chr(2) Then b(i, 1) = "←"
Next
With .Range("g1").Resize(UBound(b, 1))
.Value = b
.Replace Chr(2), ""
End With
End With
End Sub
（seiya） 2019/03/14(木) 12:26
以下、マナさんのコードを参考にさせていただきます。m(__)m
マクロ「洗い出しand集計」を実行すると以下のような結果が出ます。
<一覧 結果図> 行 ______A______ ______B______ ___C___ _J_ __K__ _L_ ______M______ 1 会社名 検索用会社名 ・・・ 金額 1行,田中 2 田中製造所 田中製造所 ・・・ 7000 2行,東洋 3 TANAKA 6行,佐藤 4 ﾀﾅｶ 7行,たなか 5 伊勢三重 8行,ﾄｰﾖｰ 6 佐藤製鉄所 佐藤製鉄所 ・・・ 12000 11行,さとう 7 SATO 13行,ﾄｰﾖｰ 8 静岡富士 9 東洋株式会社 東洋株式会社 ・・・ 7000 10 TOYO 11 東洋山梨 12 東洋名古屋
M列に集計に漏れたデータ、つまり「検索用会社名をメンテする必要がある名前」が出ますので、 全てをB列に反映させて、再度「洗い出しand集計」を実行してください。
※「田中」もチャンと一覧シートのB列に載せない限り、 集計に反映させないようにしております。 (それは、堅実な事務処理上、必須と考えます） Option Explicit
Sub 洗い出しand集計()
Const 親列 As Long = 1
Const 検索列 As Long = 2
Dim dicT As Object 'Dictionary
Dim 漏れリスト As Object 'ArrayList
Dim 一覧名s
Dim Idx As Long, RW As Long
Dim データ名, データ金額, amtAdded()
Dim VL
Dim oyaRow As Long
Set dicT = CreateObject("scripting.dictionary")
With Sheets("一覧")
一覧名s = .Range("A2", .Cells(.Rows.Count, "B").End(xlUp)).Value
ReDim amtAdded(1 To UBound(一覧名s), 1 To 1)
End With
Rem まず、一覧に重複が無いかチェックする
Dim isChecking As Boolean
For Idx = 1 To UBound(一覧名s)
If 一覧名s(Idx, 親列) <> "" Then '親行に該当
isChecking = True
oyaRow = Idx
If 一覧名s(Idx, 親列) <> 一覧名s(Idx, 検索列) Then '右隣りが親と同名かチェック
MsgBox "同行に同会社名が無いです。想定外です。処理中止。"
Exit Sub
End If
End If
If isChecking And isNew(dicT, 一覧名s(Idx, 検索列), oyaRow) = False Then
MsgBox "一覧に重複があります。(行=" & Idx + 1 & "、社名=" & _
一覧名s(Idx, 検索列) & ") 処理中止"
Exit Sub
End If
Next Idx
Rem 漏れリストを作成する。
Set 漏れリスト = CreateObject("system.collections.arraylist")
With Sheets("データ")
データ名 = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value
データ金額 = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Offset(0, 4).Value
End With
For RW = 1 To UBound(データ名)
If データ名(RW, 1) <> "" Then
VL = getUCase(データ名(RW, 1)) '統一名を取得：「株 Abc」→「株ABC」
If Not dicT.exists(VL) Then
漏れリスト.Add Application.Text(RW, "???0行、") & VL
Else
amtAdded(dicT(VL), 1) = amtAdded(dicT(VL), 1) + データ金額(RW, 1)
End If
End If
Next RW
Rem 結果を打ち出す
With Sheets("一覧")
.Range("K2").Resize(UBound(amtAdded), 1).Value = amtAdded
.Columns("M").ClearContents
If 漏れリスト.Count > 0 Then
.Range("M1").Resize(漏れリスト.Count, 1).Value = Application.Transpose(漏れリスト.toarray)
MsgBox "漏れあり、検索用会社名のメンテ要。"
Else
MsgBox "漏れはありません。"
End If
End With
End Sub
Private Function isNew(ByRef dicT As Object, ByVal Val, RW As Long) As Boolean
Dim VL
VL = getUCase(Val)
If dicT.exists(VL) Then
isNew = False
Exit Function
Else
isNew = True
dicT(VL) = RW
End If
End Function
Private Function getUCase(Val) '統一名を作る。「株 Abc」→「株ABC」
getUCase = UCase(Replace(Application.Asc(Val), " ", ""))
End Function
（半平太） 2019/03/14(木) 23:49
へんてこな二重ループが気になっていたので、修正しました。
2019/03/17(日) 23:02
If 一覧名s(Idx, 親列) <> "" Then '親行に該当
がエラーになります
（もも） 2019/03/18(月) 08:55
seiyaさんの回答もありますので、それを先に試してください。
その結果によって、私の案について検討するかどうか決めます。(あと、今日もちょっと用事があります）
（半平太） 2019/03/18(月) 10:06
アッ、私のは試したくない、或は結果が希望したのもではなかったのでしょうから無視して結構です。 （seiya） 2019/03/18(月) 10:43
金曜日の帰りにフォーマットが変わってしまいまして
【一覧】
A B ・・・ K 1 会社名 検索用会社名 ・・・ 金額
↓↓
C D ・・・ K 1 会社名 検索用会社名 ・・・ 金額
【データ】
A ・・・ E
1 会社名 金額
↓↓
K ・・・ L
1 金額 会社名
と項目の行が変わってしまったため、いただいたコードを変更する必要がありました。
半平太さまのコードは直しやすかったので、先に回答しました。
seiyaさまのはどこをどう直せばわからず格闘している真っ最中でございます。。すみません。。
（もも） 2019/03/18(月) 11:03
この式をデータのL列の横のM列に入れるマクロ
'====================名称不一致確認
Range("M2").Select
Range("M2:M" & Range("H" & Rows.Count).End(xlUp).Row).Formula = "=IF(COUNTIF(一覧!C[-9],""*""&RC[-1]&""*""),"""",""要確認"")"
を入れて解決としました。
アイデアいただきありがとうございました。
（もも） 2019/03/19(火) 17:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.