エクセルの学校：全文検索：Hyper Estraier： IF

Results of 1 - 1 of about 37650 for IF (0.008 sec.)

[[20090303194225]]: #score: 1592; @digest: fe3d882e378ee3da3379c992c2e15aab; @id: 42320; @mdate: 2009-03-29T07:26:56Z; @size: 64986; @type: text/plain; #keywords: 〒* (144048), xr2 (118249), xr1 (100239), xr3 (79084), 械名 (70896), dic3 (45346), dic1 (39106), 品個 (37884), 部品 (32224), dic2 (30303), 差異 (25271), 機械 (25076), 数種 (21647), tbl (13088), 種類 (12453), ii (9213), name (8935), 個数 (7601), workbooks (6462), array (5944), aa (5934), 会社 (5008), シー (3960), ・・ (3878), scripting (3843), ブッ (3740), デー (3638), dictionary (3464), sheets (3404), ート (3264), コー (3258), ータ (3216); 『関数とマクロ』（まんまる）
仕事でデータの差異を確認しています。例えばですが1月の売上ファイルにシートが1〜31日まであったとします。そこにaとbという組み合わせのセット品があったとして、 2月の同じ日の売上にaとbという組み合わせがあるか調べるのに今はIF関数を使ってシートごとにいれています。ファイルもシートも行も違うデータ（シート名は1〜31で同じ）をマクロか何かで簡単に抽出できる方法はあるんでしょうか? ---- マクロを使えばたいがいのことはできると思いますが詳細が全く分かりませんし、まんまるさんのマクロのスキルもわかりません。何ができれば良いのかわかりませんしどの様になさりたいのかもわかりません。＞今はIF関数を使ってシートごとにいれています。それで良いなら、これで良いと思いますがご相談に来られたということは、何か問題があるのだと思います。「aとbという組み合わせのセット品があったとして、 2月の同じ日の売上にaとbという組み合わせがあるか調べるのに」そもそも、各シートのデータはどのようなものか? 調べる為にどこに、どのようにどのような式を入れているのか。また、それではどのような点で問題があるのか（簡単でないと思っているのか）書いてみられてはどうでしょう。 (HANA) ---- 説明不足ですいません。 1月の売上というファイルにシートごとに機械名がついているとします。その各シートに部品個数種類 A 1 aa B 1 aa C 2 ab : : : : : : といった感じのデータがあります。 2月の売り上げのファイルも同じ数、名前のシート名があったとします。知りたいのは、aaという種類で各部品と数の組み合わせが1月と2月で違いがあるか知りたいのです。今やっているのはまずフィルタでaaという種類を抽出してその後 IF（1月の部品&個数=2月の部品&個数、”OK"）といった感じの関数を入れてみています。機械のシート数が多いのでシートごとに関数を入れるのが面倒で質問しました。シートのデータは列の項目は同じですが、行は各シートごとばらばらなので、マクロを使った方法があるのか、VBAの本をみてもよくわかりません。この説明で分かってもらえるかはわかりませんが、もしよい方法があるなら教えてください。 ---- いまいち分かっていません。マクロで、最終行迄の範囲に数式が入れば良いのですか? 例えば、C列に（C1用の式）=A1+B1の式を A列の最終行まで入れるのなら Range("A1", Range("A" & Rows.Count).End(xlUp)).Offset(, 2).Formula = "=A1+B1" のコードで良いですし、「数式は毎回変わってくる」なら C1セルの数式をA列の最終行までコピーと言う事で Range("C1").Copy Range("A1", Range("A" & Rows.Count).End(xlUp)).Offset(, 2) と言う書き方も出来ると思います。＞フィルタでaaという種類を抽出して部分は、「aa」が毎回変わると思うのでコードにするのは難しいと思います。＞aaという種類で各部品と数の組み合わせが1月と2月で違いがあるか知りたいこれは、二つの月の同じ名前のシートに関してのみですか? それとも、二つの月の全てのシート（同じ名前のシートの組合せで）に関して調査が必要なのでしょうか? (HANA) ---- 差異をすべてのシートで調べたいのです。フィルタでaaが抽出済みでもむずかしいんでしょうか? 簡単にいうとセルAとセルBの組み合わせのものがちがうシートであるかないか調べたいんです。うまく説明できなくてすいません。本も見ても違うシートをつかったマクロの作り方が載っていなくて・・というかどれを参考にしていいか分からない状態なのです。今は入れたIF関数の結果がfalseを見てその組み合わせがあるかないかいちいち見ている状態です。違うファイルのシートなので、関数を入れる時に「1月のこの機械のセルA」といった風にしなければならないのでなにか方法はないかと思って質問させていただいたんですが、うまく説明できなくてすいません。 ---- 分かりそうで分からないと言うか雲に手を突っ込んでかき回してる感じです。^^ 取り敢えず、ブックとシートの詳細を教えてもらえませんかね。例えば・・・・・・・・・・・・ファイル名「1月の売上」シート名「機械1」 [A] [B] [C] [1] 部品個数種類 ←1行目が見出し [2] A 1 aa ←2行目からデータ [3] B 1 aa [4] C 2 ab [5] ←最終行はシート毎に異なる A:Cの3列のみデータが入っていて、その他の列は空き列データの有る行は、全ての列にデータが入っている一つのファイルには、シート名を「機械名」とした上記と同じレイアウトのシートが有る（その他のシートは含まれない）・・・・・・・と言った感じで。それから、シートの枚数と最大何行まで使用される可能性があるか教えて下さい。もしかして、最終行はシート毎に異なるけど違う月の一つの同じシートを見たときの最終行は同じなんですかね? そして、データの順番も同じ? (HANA) ---- 本当にうまく説明できなくてすいません。シートの枚数は50くらいで最大だと200以上の行があります。例えばですがファイル名「1月の売上」シート名「機械1」 [A] [B] [C] [1] 部品個数種類 ←1行目が見出し [2] A 1 aa ←2行目からデータ [3] B 1 aa [4] C 2 ab [5] : : : ファイル名「2月の売上」シート名「機械1」 [A] [B] [C] [1] 部品個数種類 ←1行目が見出し [2] A 1 aa ←2行目からデータ [3] B 1 aa [4] C 2 ab [5] D 3 aa [6] : : : 上記の1月と2月を比べると5行目のDと3が増えている・・・。といった差違を見ています。各ファイルのシート名は「機械1」、「機械2」・・・といった感じですべて同じです。データの順番もほとんど同じですが時々、違う時もあります。ほとんど差異が見つからないデータなんですが、シートごとに関数を入れている状態をマクロか何かできないか、ほかにいい方法はないか、とやんで悩んでいるところです。説明になったでしょうか・・・? ---- レイアウトは分かりました。これは実際のレイアウトと同じですか? また、その他の件はどうなっていますか? たとえば ●A:Cの3列のみデータが入っていて、その他の列は空き列データの有る行は、全ての列にデータが入っている ●一つのファイルには、シート名を「機械名」とした上記と同じレイアウトのシートが有る（その他のシートは含まれない）等です。実際のデータ配置・入力状況や、ブックの状態も教えて下さい。 (HANA) ---- 会社の資料なので、ぼんやりなんですが列はほかにもあって5か6列くらいです。知りたいのは、A列B列の組み合わせだけです。行によってはデータが入ってない行もあります。 A〜Cの列はすべてデータが入っています。シートは1月が「機械名A」から「機械名R」まであるとすると2月も同様で、シートが増えたりすることはありません。 [A] [B] [C] [D] [E] [1] 部品個数種類業者名備考欄 [2] A 1 aa あ * [3] B 1 aa * [4] C 2 ab い * [5] D 3 aa い * [6] : : : : : といった感じです。 ---- 分かりました。マクロが出来たので載せておきます。ブックを一つ用意してください。ブックには、Sheet1 のシート名のシートを用意しておいてください。標準モジュールに、以下のコードを貼り付け。 '------ Sub 検索() Dim dic1 As Object, dic2 As Object Dim x As Variant, y As Variant, z As Variant Dim xr As Variant, tbl As Variant Dim wbn1 As String, wbn2 As String Dim st As String Dim i As Long, ii As Long Dim xi As Long, yi As Long, flg As Long If Workbooks.Count > 4 Then MsgBox "不要ブックは閉じてください。" Exit Sub End If If Workbooks.Count < 3 Then MsgBox "検索するブックを開いてください。" Exit Sub End If st = InputBox("調べる種類を入力してください。") If st = "" Then MsgBox "検索を中止します。" Exit Sub End If Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For Each z In Workbooks If z.Name <> ThisWorkbook.Name Then If wbn1 = "" Then wbn1 = z.Name Else wbn2 = z.Name End If End If Next xi = Application.Max(Workbooks(wbn1).Sheets.Count, Workbooks(wbn2).Sheets.Count) ReDim x(1 To Rows.Count, 1 To 3, 1 To xi) With Workbooks(wbn1) For i = 1 To .Sheets.Count With .Sheets(i) dic1(.Name) = Array(i, 0, 0) tbl = .Range("A2", .Range("C" & .Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) If tbl(ii, 3) = st Then flg = 1 dic2(.Name & "_" & tbl(ii, 1)) = Array(.Name, tbl(ii, 1), tbl(ii, 2)) End If Next End With Next End With With Workbooks(wbn2) For i = 1 To .Sheets.Count With .Sheets(i) If Not dic1.Exists(.Name) Then dic1(.Name) = Array(i, 0, 1) Else tbl = .Range("A2", .Range("C" & .Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) If tbl(ii, 3) = st Then flg = 1 xr = dic1(.Name) If dic2.Exists(.Name & "_" & tbl(ii, 1)) Then If dic2(.Name & "_" & tbl(ii, 1))(2) <> tbl(ii, 2) Then xr(1) = xr(1) + 1 x(xr(1), 1, xr(0)) = tbl(ii, 1) x(xr(1), 2, xr(0)) = dic2(.Name & "_" & tbl(ii, 1))(2) x(xr(1), 3, xr(0)) = tbl(ii, 2) dic1(.Name) = xr End If dic2.Remove (.Name & "_" & tbl(ii, 1)) Else xr(1) = xr(1) + 1 x(xr(1), 1, xr(0)) = tbl(ii, 1) x(xr(1), 3, xr(0)) = tbl(ii, 2) dic1(.Name) = xr End If End If Next xr = dic1(.Name) xr(2) = 2 dic1(.Name) = xr End If End With Next End With For Each z In dic2.Items xr = dic1(z(0)) xr(1) = xr(1) + 1 x(xr(1), 1, xr(0)) = z(1) x(xr(1), 2, xr(0)) = z(2) dic1(z(0)) = xr Next ReDim y(1 To Rows.Count, 1 To 3) For Each z In dic1.Keys xr = dic1(z) yi = yi + 1 y(yi, 1) = z If xr(2) = 2 Then If xr(1) > 0 Then For i = 1 To xr(1) yi = yi + 1 y(yi, 1) = x(i, 1, xr(0)) y(yi, 2) = x(i, 2, xr(0)) y(yi, 3) = x(i, 3, xr(0)) Next Else yi = yi + 1 y(yi, 1) = "不一致なし" End If Else yi = yi + 1 y(yi, IIf(xr(2) = 0, 2, 3)) = "対応シートなし" End If yi = yi + 1 Next With ThisWorkbook.Sheets("Sheet1") .Range("A:C").ClearContents .Range("A1:B1").Value = Array("種類", st) .Range("A2:B2").Value = Array("検索日", Date) .Range("B4:C4") = Array(wbn1, wbn2) If flg = 1 Then .Range("A5").Resize(yi, 3).Value = y Else .Range("A5") = "該当種類なし" End If End With Set dic1 = Nothing Set dic2 = Nothing MsgBox "検索が終了しました。" End Sub '------ このブックと、調べたい二つのブックの合計3つを開いた状態で「検索」を実行してください。＞ほとんど差異が見つからないデータなんですがこれを信じて、書き出し行数のチェックはしていません。一回でエラーも出ずご希望の結果が出力できるとは思っていませんので不具合がある場合は、教えて下さい。 (HANA) ---- ありがとうございます!! 説明不足だったのにもかかわらずお付き合いいただいてすいません。。やってみたのですが、”調べる種類を入力してください”とういうのが出ました。これは何か入力しないといけないんでしょうか? 会社のデータできちんとしたほうがいいんでしょうけれども、持ち出せないので・・・。 ---- ん? 【aaという種類で】各部品と数の組み合わせが1月と2月で違いがあるかを調べたいのですよね? ですから「aa」を入力してもらうことになるのですが。。。 (HANA) ---- すいません!! 入力したんですが、エラーでした。「インデックスが有効範囲にありません」と出ました。 With ThisWorkbook.Sheets("Sheet1")の部分が黄色くなっていました。どうすればよいでしょうか? 度々、すみません・・・。 ---- えっと、マクロを貼り付けたブックに「Sheet1」というシート名のシートはありますか? これがない時に、そのエラーが出るのですが・・・。とりあえず、コード内で一部変更があったのでもう一度貼り替えてやってみてください。結果を書き出すシートは、マクロを貼り付けたブックの一番左にあるシートにしてます。まずは、これでテストしてみてください。 (HANA) ---- こんにちは。かみちゃんです。横から失礼します。 > 「インデックスが有効範囲にありません」と出ました。 With ThisWorkbook.Sheets("Sheet1")の部分 > が黄色くなっていましたマクロを記述しているブック（ThisWorkbook）に、Sheet1という名前のシートがない場合、そのエラーになります。 (かみちゃん) 2009-03-07 22:29 ---- ニアミス。（笑）もう一度書いておきます。このマクロは、新規作成したブックに貼り付けてください。今回＞結果を書き出すシートは、＞マクロを貼り付けたブックの一番左にあるシートにしてます。ので、くれぐれもデータのあるブックには貼りつけないで下さい。シートを一枚だけにして、シート名をコピーし＞With ThisWorkbook.Sheets(1) の括弧の中に貼り付けてもらうのが確実なのですが。その際、シート名の前後を「""」ではさんで下さい。たとえばシート名を「結果」にした場合、コードは With ThisWorkbook.Sheets("結果") にしてください。 (HANA) ---- こんにちは。かみちゃんです。 > ニアミス。（笑）私がコメントを書いたときに衝突したのですが、そのままアップしてしまいました。 >> マクロを記述しているブック（ThisWorkbook）が言いたかっただけで、他意はありません。あとは、お任せすることとし、静観します。横入り申し訳ありませんでした。 (かみちゃん) 2009-03-07 22:52 ---- To,かみちゃんさん実は、私はまんまるさんんと衝突してたんですよ。（それで、レスがはやかった。）返信・編集でコードを修正中だったのでもう一度貼り付け直して、コメントを書いて・・・・かみちゃんさんの一歩前に投稿できてよかったと胸をなでおろしていただけです。^^ 通常なら、コメント欄から貼り付け直すだけなので大してなんともないのですけどね〜。そして、ついでにコードも変更。 dic2から出すときは、直接Itemを出せば良かったですね。 (HANA) ---- おはようございます! もうお昼ですが・・・。さっそく、やってみました!私はなんか感じがいしてsheet1に同じ名前をつかていました（・・;） sheet1にしたらできました!! ありがとうございます! お手数おかけし申し訳ありませんでした。私の説明不足のわけのわからない質問にお付き合いくださり、本当に感謝感謝です! エクセルの奥深さを感じました。私も少しはHANAさんのようになれるよう、これから精進いたします。本当に、お世話掛けました。また、わけのわからない質問をするかもしれませんが、またよろしかったらよろしくお願いいたします! ---- 出来ましたか、よかったです。まだ、テストデータの段階ですよね? 実データでもうまくいくと良いのですが。一つ、注意点があります。検索値は、大文字小文字までも含めて一致するものを同じとみなします。種類の入力を間違えると「検索値なし」と表示されてしまいます。とりあえず、調べたすべてのシートで同じ種類のものが見つからなかったら「該当種類なし」と表示するようにコードを変更しました。一つも見つからなければ、たぶん入力ミスでしょうから。。。。一つでも見つかったら、正しく入力されているとみなします。お手数ですが、もう一度貼り替えていただければと思います。＜注＞書き出しシート名を「Sheet1」に戻しました。 (HANA) ---- ありがとうございます! 明日時間の都合でできるかはわかりませんが、会社でもチャレンジしたいと思います。 ---- 会社でもできました。列数はちょっと違うかったのですがなんとかできました。検索する種類をaから始まる「aa,ab,ac・・」といたふうに「a*」として検索するのはどうしたらよいでしょうか?コードのどこを変更したらできるかいろいろしたんですがわかりませんでした。「a*」と種類を入力したら「aa、ab・・・」といった分の差異を調べられる方法があるんでしたら教えてください。 ---- その様に検索しても、部品が重複することは無いのですか? aaの検索の後、続いてabの検索をするのではなく aで始まる種類の部品同士の個数を調べるのですよね? 1月に種類「aa」部品「A」数量「1」 2月に種類「ab」部品「A」数量「1」これは差異無し 1月に種類「aa」部品「B」数量「1」種類「ab」部品「B」数量「1」 2月に種類「ac」部品「B」数量「1」どれが差異ですか? 全ての種類を通して、部品が重複することが無いのならコードを作り替えれば差異を調べられるとは思います。ただし「ここを変更」と言えるような小さな変更にはならないと思います。（今は、種類はB1セルにしか出してませんし。）部品が重複しないなら、出力レイアウトを作って載せて下さい。「a*」（○○で始まる）のパターンだけで良ければ対応するコードにしますので。そうそう、コメント記入の際は文頭に半角スペースを入れてください。 _←ここに半角スペースです。改行がそのまま表示できるようになりますので。また、分かりやすいところにご署名も御願いします。 (HANA) ---- 会社できちんと確認すると、下記のようでした。 [A] [B] [C] [D] [E] [1] 部品個数種類業者名備考欄 [2] A 1 aa あ * [3] B 1 aa * [4] C 2 ab い * [5] D 2 ab い * [6] E 3 bb い * [7] : : : : : 種類をaから始まるものだけで検索し、他の月との差異を調べるというものでした。部品は1,2個ほどダブりますが、ほとんどかぶりません。説明になってますか? ＜まんまる＞ ---- 済みません、遅くなりました。ダブった場合の不一致がよく分からないのでテキトウに作ってみました。既につぎはぎコードですので、これ以上の改造は難しくなっていると思います。取り敢えず載せておきます。 '------ Sub 検索2() Dim dic1 As Object, dic2 As Object, dic3 As Object Dim x As Variant, y As Variant, z As Variant Dim xr1 As Variant, xr2 As Variant, xr3 As Variant, tbl As Variant Dim wbn1 As String, wbn2 As String Dim stm As String, st As String, kt As Long Dim i As Long, ii As Long, iii As Long Dim xi As Long, yi As Long, si As Long Dim flg As Long, flg1 As Long, flg2 As Long If Workbooks.Count > 4 Then MsgBox "不要ブックは閉じてください。" Exit Sub End If If Workbooks.Count < 3 Then MsgBox "検索するブックを開いてください。" Exit Sub End If stm = InputBox("調べる種類を入力してください。") If stm = "" Then MsgBox "検索を中止します。" Exit Sub End If kt = 1024 st = stm If Right(st, 1) = "*" Then kt = Len(st) - 1 st = Left(st, kt) If st = "" Then MsgBox "検索を中止します。" Exit Sub End If End If Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") Set dic3 = CreateObject("scripting.dictionary") For Each z In Workbooks If z.Name <> ThisWorkbook.Name Then If wbn1 = "" Then wbn1 = z.Name Else wbn2 = z.Name End If End If Next With Workbooks(wbn1) For i = 1 To .Sheets.Count With .Sheets(i) si = i dic1(.Name) = Array(si, 0, 0) tbl = .Range("A2", .Range("C" & .Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) If Left(tbl(ii, 3), kt) = st Then If dic2.Exists(.Name & "_" & tbl(ii, 1)) Then xr2 = dic2(.Name & "_" & tbl(ii, 1)) xr2(1) = xr2(1) + 1 dic2(.Name & "_" & tbl(ii, 1)) = xr2 Else flg = 1 dic2(.Name & "_" & tbl(ii, 1)) = Array(.Name, 1, 0) End If xr2 = dic2(.Name & "_" & tbl(ii, 1)) dic3(.Name & "_" & tbl(ii, 1) & "_" & xr2(1)) = _ Array(0, tbl(ii, 1), tbl(ii, 2), tbl(ii, 3), "", "", "", si, .Name) End If Next End With Next End With With Workbooks(wbn2) For i = 1 To .Sheets.Count With .Sheets(i) If Not dic1.Exists(.Name) Then si = si + 1 dic1(.Name) = Array(si, 0, 1) Else tbl = .Range("A2", .Range("C" & .Rows.Count).End(xlUp)) flg2 = 3 For ii = 1 To UBound(tbl, 1) If Left(tbl(ii, 3), kt) = st Then flg = 1 xr1 = dic1(.Name) If dic2.Exists(.Name & "_" & tbl(ii, 1)) Then xr2 = dic2(.Name & "_" & tbl(ii, 1)) For iii = 1 To xr2(1) xr3 = dic3(.Name & "_" & tbl(ii, 1) & "_" & iii) If xr3(2) = tbl(ii, 2) Then If xr3(0) = 0 Then xr3(0) = 1 xr3(4) = tbl(ii, 1) xr3(5) = tbl(ii, 2) xr3(6) = tbl(ii, 3) dic3(.Name & "_" & tbl(ii, 1) & "_" & iii) = xr3 xr2(2) = xr2(2) + 1 dic2(.Name & "_" & tbl(ii, 1)) = xr2 flg1 = 1 flg2 = 3 Exit For End If End If Next If flg1 <> 1 Then xr1 = dic1(.Name) xr2 = dic2(.Name & "_" & tbl(ii, 1)) xr2(1) = xr2(1) + 1 dic2(.Name & "_" & tbl(ii, 1)) = xr2 dic3(.Name & "_" & tbl(ii, 1) & "_" & xr2(1)) = _ Array(0, "", "", "", tbl(ii, 1), tbl(ii, 2), tbl(ii, 3), xr1(0), .Name) flg2 = 2 End If flg1 = 0 Else flg = 1 dic2(.Name & "_" & tbl(ii, 1)) = Array(.Name, 1, 0) xr1 = dic1(.Name) xr2 = dic2(.Name & "_" & tbl(ii, 1)) dic3(.Name & "_" & tbl(ii, 1) & "_" & xr2(1)) = _ Array(0, "", "", "", tbl(ii, 1), tbl(ii, 2), tbl(ii, 3), xr1(0), .Name) flg2 = 2 End If End If Next xr1 = dic1(.Name) xr1(2) = flg2 dic1(.Name) = xr1 End If End With Next End With For Each z In dic2.Keys xr2 = dic2(z) If xr2(2) <> 0 And xr2(1) <> xr2(2) Then xr1 = dic1(xr2(0)) xr1(2) = 2 dic1(xr2(0)) = xr1 For iii = 1 To xr2(1) xr3 = dic3(z & "_" & iii) xr3(0) = 0 dic3(z & "_" & iii) = xr3 Next End If Next ReDim x(1 To Rows.Count, 1 To 9) For Each z In dic3.Keys xr3 = dic3(z) xr1 = dic1(xr3(8)) If xr1(2) <> 0 And xr3(0) = 0 Then xi = xi + 1 x(xi, 1) = xr3(7) x(xi, 2) = z x(xi, 3) = xr3(8) For i = 1 To 6 x(xi, i + 3) = xr3(i) Next xr1(2) = 2 dic1(xr3(8)) = xr1 End If Next For Each z In dic1.Keys xr1 = dic1(z) If xr1(2) <> 2 Then xi = xi + 1 x(xi, 1) = xr1(0) x(xi, 3) = z If xr1(2) = 0 Then x(xi, 7) = "◆対応シートなし◆" ElseIf xr1(2) = 1 Then x(xi, 4) = "◆対応シートなし◆" ElseIf xr1(2) = 3 Then x(xi, 4) = "不一致なし" End If End If Next With ThisWorkbook.Sheets("Sheet1") .Range("A:I").ClearContents With .Range("A1").Resize(xi, 9) .Value = x .Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range( _ "B1"), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase _ :=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _ xlSortNormal, DataOption2:=xlSortNormal tbl = .Value End With ReDim y(1 To Rows.Count, 1 To 7) For i = 1 To UBound(tbl, 1) If i = 1 Then yi = yi + 1 y(yi, 1) = tbl(i, 3) ElseIf tbl(i - 1, 1) <> tbl(i, 1) Then yi = yi + 2 y(yi, 1) = tbl(i, 3) End If yi = yi + 1 If tbl(i, 4) = "不一致なし" Then y(yi, 1) = tbl(i, 4) Else For ii = 1 To 6 y(yi, ii + 1) = tbl(i, ii + 3) Next End If Next .Range("A:I").ClearContents .Range("A1:B1").Value = Array("種類", stm) .Range("A2:B2").Value = Array("検索日", Date) .Range("B4:E4") = Array(wbn1, "", "", wbn2) .Range("B5:D5,E5:G5") = Array("部品", "個数", "種類") If flg = 1 Then .Range("A6").Resize(yi, 7).Value = y Else .Range("A6") = "該当種類なし" End If End With Set dic1 = Nothing Set dic2 = Nothing Set dic3 = Nothing MsgBox "検索が終了しました。" End Sub '------ (HANA) ---- ありがとうございます!! わがままに付き合っていただき、感謝感謝です!! また質問をするかもしれませんが、その時もどうぞよろしくお願いいたします（^◇^）/ （まんまる） ---- やっぱり（笑）うまくいかなかったのでコードを変更しておきます。うまくいくデータだと、うまくいくのですが。。。まぁ、なるべくうまくいく方が良いと思いますので。 (HANA) ---- こんばんわ。変更していただいた前のコードでなんとかできました。今回変更していただいたのは具体的にどのようになったんでしょうか? 会社のデータは1,2,3列ではなく2列目と4〜6は違うデータがありなおかつ、1行一番上に機械名が入っているので、ちょっとコードを変えないといけないんですが、tblのところの数字を変えればいいんですよね?（すいません、素人なもんで・・・）あと、 .Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range( _ "B1"), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase _:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _xlSortNormal,DataOption2:=xlSortNormal のところがいつも”_は不正な文字です”となるので、_をはずしたんですが、いいんでしょうか? （まんまる） ---- えっと・・・消す前のコードはデータの状況によっては違った結果になります。＞会社のデータは1,2,3列ではなく2列目と4〜6は違うデータがあり＞なおかつ、1行一番上に機械名が入っているのでという事ですが・・・ 2行目に見出しで、データが3行目から始っていますか? でしたら、tblに取り込む範囲も変更しておいた方が良いと思います。あとは、列番号をそろえて変更してください。＞”_は不正な文字です”となるので、_をはずしたんですが、いいんでしょうか? これは、「一行にする」ということですか? 「_」の前に半角スペース・後ろで改行されていたら、メッセージは出ないと思いますが・・・。 (HANA) ---- そうですか・・・。来週、また再チャレンジしてみます! お返事、ありがとうございました!! （まんまる） ---- 会社でチャレンジしました・・・。が、やっぱりどこを変えていいかわかりません(;O;) よくよくみると、会社のデータは1行1列余分にあって、A1からではなく、B2からデータが始まっていました・・。全体としては、2列、4列、8列目のデータを調べることになります。2列4列の組み合わせが8列目のデータであるかないか・・といった感じです。コードに合わせて、行と列を消し、1列から3列のデータにするとできたんで、コードのどこを変えるのか、もしよかったら教えてください! （まんまる） ---- それではもう一度＞会社できちんと確認すると、下記のようでした。の下に書いておられるようにして「正確な配置」を教えて下さい。見出し行はどこか? データは何行目から始まっているか? 2,4,8列目に入っているのはそれぞれどの項目か? 等。 (HANA) ---- 会社のデータはこんな感じです。 A B C D E F G H 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa 4 B b 2 〒 * aa 5 C c 1 い〒 * aa 6 D d 1 い〒 * ab 7 E e 1 あ〒 * aa 8 F f 1 あ〒 * aa 9 : : : : : : : と、各シートがなっています。種類別に各ファイルの同じ機械名の部品と個数の組み合わせの差異を調べています。使うデータとしては、B,D,Hです。前のコードではA,C,E,F,Gおよび1行目を消してしたらうまくできたんですが・・・。やはり、データの形式を変更せずにしたいので、またまた質問しました。よろしくご教授お願いします。（まんまる） ---- 一応変更しました。動かしていないのでうまくいかないかもしれません。その場合は、気合いを入れて変更しますのでお知らせください。 '------ Sub 検索3() Dim dic1 As Object, dic2 As Object, dic3 As Object Dim x As Variant, y As Variant, z As Variant Dim xr1 As Variant, xr2 As Variant, xr3 As Variant, tbl As Variant Dim wbn1 As String, wbn2 As String Dim stm As String, st As String, kt As Long Dim i As Long, ii As Long, iii As Long Dim xi As Long, yi As Long, si As Long Dim flg As Long, flg1 As Long, flg2 As Long If Workbooks.Count > 4 Then MsgBox "不要ブックは閉じてください。" Exit Sub End If If Workbooks.Count < 3 Then MsgBox "検索するブックを開いてください。" Exit Sub End If stm = InputBox("調べる種類を入力してください。") If stm = "" Then MsgBox "検索を中止します。" Exit Sub End If kt = 1024 st = stm If Right(st, 1) = "*" Then kt = Len(st) - 1 st = Left(st, kt) If st = "" Then MsgBox "検索を中止します。" Exit Sub End If End If Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") Set dic3 = CreateObject("scripting.dictionary") For Each z In Workbooks If z.Name <> ThisWorkbook.Name Then If wbn1 = "" Then wbn1 = z.Name Else wbn2 = z.Name End If End If Next With Workbooks(wbn1) For i = 1 To .Sheets.Count With .Sheets(i) si = i dic1(.Name) = Array(si, 0, 0) tbl = .Range("A3", .Range("H" & .Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) If Left(tbl(ii, 8), kt) = st Then If dic2.Exists(.Name & "_" & tbl(ii, 2)) Then xr2 = dic2(.Name & "_" & tbl(ii, 2)) xr2(1) = xr2(1) + 1 dic2(.Name & "_" & tbl(ii, 2)) = xr2 Else flg = 1 dic2(.Name & "_" & tbl(ii, 2)) = Array(.Name, 1, 0) End If xr2 = dic2(.Name & "_" & tbl(ii, 2)) dic3(.Name & "_" & tbl(ii, 2) & "_" & xr2(1)) = _ Array(0, tbl(ii, 2), tbl(ii, 4), tbl(ii, 8), "", "", "", si, .Name) End If Next End With Next End With With Workbooks(wbn2) For i = 1 To .Sheets.Count With .Sheets(i) If Not dic1.Exists(.Name) Then si = si + 1 dic1(.Name) = Array(si, 0, 1) Else tbl = .Range("A3", .Range("H" & .Rows.Count).End(xlUp)) flg2 = 3 For ii = 1 To UBound(tbl, 1) If Left(tbl(ii, 8), kt) = st Then flg = 1 xr1 = dic1(.Name) If dic2.Exists(.Name & "_" & tbl(ii, 2)) Then xr2 = dic2(.Name & "_" & tbl(ii, 2)) For iii = 1 To xr2(1) xr3 = dic3(.Name & "_" & tbl(ii, 2) & "_" & iii) If xr3(2) = tbl(ii, 4) Then If xr3(0) = 0 Then xr3(0) = 1 xr3(4) = tbl(ii, 2) xr3(5) = tbl(ii, 4) xr3(6) = tbl(ii, 8) dic3(.Name & "_" & tbl(ii, 2) & "_" & iii) = xr3 xr2(2) = xr2(2) + 1 dic2(.Name & "_" & tbl(ii, 2)) = xr2 flg1 = 1 flg2 = 3 Exit For End If End If Next If flg1 <> 1 Then xr1 = dic1(.Name) xr2 = dic2(.Name & "_" & tbl(ii, 2)) xr2(1) = xr2(1) + 1 dic2(.Name & "_" & tbl(ii, 2)) = xr2 dic3(.Name & "_" & tbl(ii, 2) & "_" & xr2(1)) = _ Array(0, "", "", "", tbl(ii, 2), tbl(ii, 4), tbl(ii, 8), xr1(0), .Name) flg2 = 2 End If flg1 = 0 Else flg = 1 dic2(.Name & "_" & tbl(ii, 2)) = Array(.Name, 1, 0) xr1 = dic1(.Name) xr2 = dic2(.Name & "_" & tbl(ii, 2)) dic3(.Name & "_" & tbl(ii, 2) & "_" & xr2(1)) = _ Array(0, "", "", "", tbl(ii, 2), tbl(ii, 4), tbl(ii, 8), xr1(0), .Name) flg2 = 2 End If End If Next xr1 = dic1(.Name) xr1(2) = flg2 dic1(.Name) = xr1 End If End With Next End With For Each z In dic2.Keys xr2 = dic2(z) If xr2(2) <> 0 And xr2(1) <> xr2(2) Then xr1 = dic1(xr2(0)) xr1(2) = 2 dic1(xr2(0)) = xr1 For iii = 1 To xr2(1) xr3 = dic3(z & "_" & iii) xr3(0) = 0 dic3(z & "_" & iii) = xr3 Next End If Next ReDim x(1 To Rows.Count, 1 To 9) For Each z In dic3.Keys xr3 = dic3(z) xr1 = dic1(xr3(8)) If xr1(2) <> 0 And xr3(0) = 0 Then xi = xi + 1 x(xi, 1) = xr3(7) x(xi, 2) = z x(xi, 3) = xr3(8) For i = 1 To 6 x(xi, i + 3) = xr3(i) Next xr1(2) = 2 dic1(xr3(8)) = xr1 End If Next For Each z In dic1.Keys xr1 = dic1(z) If xr1(2) <> 2 Then xi = xi + 1 x(xi, 1) = xr1(0) x(xi, 3) = z If xr1(2) = 0 Then x(xi, 7) = "◆対応シートなし◆" ElseIf xr1(2) = 1 Then x(xi, 4) = "◆対応シートなし◆" ElseIf xr1(2) = 3 Then x(xi, 4) = "不一致なし" End If End If Next With ThisWorkbook.Sheets("Sheet1") .Range("A:I").ClearContents With .Range("A1").Resize(xi, 9) .Value = x .Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal tbl = .Value End With ReDim y(1 To Rows.Count, 1 To 7) For i = 1 To UBound(tbl, 1) If i = 1 Then yi = yi + 1 y(yi, 1) = tbl(i, 3) ElseIf tbl(i - 1, 1) <> tbl(i, 1) Then yi = yi + 2 y(yi, 1) = tbl(i, 3) End If yi = yi + 1 If tbl(i, 4) = "不一致なし" Then y(yi, 1) = tbl(i, 4) Else For ii = 1 To 6 y(yi, ii + 1) = tbl(i, ii + 3) Next End If Next .Range("A:I").ClearContents .Range("A1:B1").Value = Array("種類", stm) .Range("A2:B2").Value = Array("検索日", Date) .Range("B4:E4") = Array(wbn1, "", "", wbn2) .Range("B5:D5,E5:G5") = Array("部品", "個数", "種類") If flg = 1 Then .Range("A6").Resize(yi, 7).Value = y Else .Range("A6") = "該当種類なし" End If End With Set dic1 = Nothing Set dic2 = Nothing Set dic3 = Nothing MsgBox "検索が終了しました。" End Sub '------ (HANA) ---- こんばんわ。会社で試したんですがうまくいきませんでした・・・。が、家で試しにやってみたのはうまくいきました。また、会社で再チャレンジします。ありがとうございました。（まんまる） ---- 特にバージョンに左右されそうな処理はないのですが。。。とりあえず、落ち着いて再チャレンジしてみてください。それでもうまくいかない場合は OSとエクセルのバージョンどの様にうまくいかないのか教えて下さい。＞コードに合わせて、行と列を消し、1列から3列のデータにするとできたんでこれって、ご自宅で出来たのですかね? それとも、このときは職場でも出来た? (HANA) ---- こんばんわ。再チャレンジ、できませんでした。＞コードに合わせて、行と列を消し、1列から3列のデータにするとできたんで・・・は、会社でできました。家ではできたのになぜか会社では、差異があるのに、不一致なし、となるのです。会社は、xpで、家はビスタです。エクセルは、家は2007?です・・。会社は98か、2000くらいでしょうか・・・。（まんまる） ---- ご自宅で試しておられるデータは職場のデータに似せて作ったデータですよね? それとも、同じデータですか? とりあえず職場で以下のブックを作成し結果をこちらへ載せて下さい。 1.テスト1.xlsの作成 Sheet1に以下のデータ [A] [B] [C] [D] [E] [F] [G] [H] [1] 機械名 [2] 部品品名個数業者名住所備考種類 [3] A a 1 あ〒 * aa [4] B b 2 〒 * aa [5] C c 1 い〒 * ab 不要シートを削除して、保存 2.テスト2.xlsの作成 Sheet1に以下のデータ [A] [B] [C] [D] [E] [F] [G] [H] [1] 機械名 [2] 部品品名個数業者名住所備考種類 [3] A a 1 あ〒 * aa [4] B b 2 〒 * ab [5] C c 1 い〒 * ab 不要シートを削除して、保存 3.マクロ実行結果種類に「aa」を指定すると、こちらでは以下のようになります。 [A] [B] [C] [D] [E] [F] [G] [1] 種類 aa [2] 検索日 2009/3/25 [3] [4] テスト1.xls テスト2.xls [5] 部品個数種類部品個数種類 [6] Sheet1 [7] B 2 aa テストデータの作成は、こちらからコピーしてエクセル上で右クリック→形式を選択して貼り付けで「テキスト」を選んで貼り付けたのち、データがA1セルから始まる様不要行列の削除を行い、整えてください。 (HANA) ---- 毎回毎回お世話になります。会社で、さあいざ!と思ってやろうとすると根本的に・・というか最初から質問していた内容が少間違っていたことに気付きました。 A B C D E F G H 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa 4 B b 2 〒 * aa 5 C c 1 い〒 * aa 6 D d 1 い〒 * ab 7 E e 1 あ〒 * aa 8 F f 1 あ〒 * aa 9 : : : : : : : というデータで差異を調べていくのですが、種類も差異があることがわかったので、結局はB、D,H,の組み合わせが、他のファイルのシートにあるかないか、ということを調べる、ということになります。また、1のファイルは上記のようで、くらべるファイルは A B C D E F G H 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa 4 B b 2 〒 * aa 5 C c 1 い〒 * aa 6 D d 1 い〒 * ab 7 E e 1 あ〒 * aa 8 G g 1 あ〒 * ac 9 F f 1 あ〒 * aa 10 : : : : : : : というように、商品が増えて行がずれます。これまで教えていただいたのを、どう変更したらよいでしょうか? 本当にマクロのことをまったく理解していなくて変な質問ばかりして申し訳ありません・・・。（まんまる） ---- 仰っておられる意味がよくわかりません。結局、コードは動いたのですか?動かないのですか? 結果を載せてくださってない様ですが。このコードは＞aaという種類で各部品と数の組み合わせが1月と2月で違いがあるかというご質問から出来ているコードです。つまり「○○という種類で」の部分はこのコードの根幹部分です。また、検索2のコードを載せた時に「既につぎはぎコードですので、これ以上の改造は難しくなっていると思います。」と書きました様に、改造（しかも基本部分が絡む）をするのは困難です。非常に不思議に思うのですが、今まで手作業で行っておられたのですよね? (HANA) ---- 結果をもうしますと、「不一致なし」となりました。会社に自宅からデータを持って行けないので、コードをプリントして打ち込みましたが、うまくいきませんでした。どこか、間違っているようなのですが、何回見直しても間違っているところがわかりませんでした。コピーして家でやるとうまくいくので、やはり、私が打ち間違えているのだと思います。「○○という種類で」というのを考えていたのですが、部品と個数が同じで、種類がちがう、たとえばaa、abだったら、a*で検索すると、差異がないということになります。会社で他の人に指摘されて、部品+個数の組み合わせが同じで種類が違うというのがあると気付きました。種類で検索するのではなく、部品+個数+種類の組み合わせの差異を調べることはできるのかと思ったのですが・・・。（まんまる） ---- 最初に書きましたように、マクロを使えばたいがいのことはできると思います。ですから「部品+個数+種類の組み合わせの差異を調べること」も出来ますよ。但し、『その様なコードを書けば』と言う事になりますが。まんまるさんの場合はもう一つ『正確にそのコードを入力出来れば』というのもつきますね。そこで質問ですが、一つのシートのデータ量はどのくらいでしょう? 最少何行から最大何行くらい? また、平均何行有りますか? (HANA) ---- いつもありがとうございます。データは最少40行くらいから最大300くらいです。平均で100くらいです。会社にあるマクロの本を見て勉強しているのですが、なかなか理解できなくてこちらのサイトにお世話になりっぱなしで、ご迷惑かけます。（まんまる） ---- おそらく、これ以上マクロの話を続けても良い結果にはなりそうにないので数式で次の様にするのはどうでしょう。まず、ブックを一つ作成し「確認.xls」の名前で保存してください。検索する二つのブックを開いておいてください。 A1セルに検索するシート名を A3セルに検索する一つのブックのブック名 D3セルにもうひとつのブック名を入れて下さい。また、4行目は見出し行を設定します。 H4セルには「=A3」I4セルには「=D3」の式を入力するか適当な見出しを付けて下さい。ここを作業列に使用します。仮に機械名が「AAA」検索する二つのブックが「1月」「2月」であれば、この様な状態です。 [A] [B] [C] [D] [E] [F] [G] [H] [I] [1] AAA [2] [3] 1月 2月 [4] 部品個数種類部品個数種類確認 1月 2月 [5] [6] 次に、数式を入れて行きます A5セルに =INDIRECT("["&$A$3&".xls]"&$A$1&"!B"&ROW(A3)) B5セルに =INDIRECT("["&$A$3&".xls]"&$A$1&"!D"&ROW(B3)) C5セルに =INDIRECT("["&$A$3&".xls]"&$A$1&"!H"&ROW(C3)) これで、A3セルに入力されているブック名の A1セルに入力されているシート名の B,D,H列の値がそれぞれ参照できるようになりますので必要行フィルドラッグしてください。参照先のセルにデータがない場合は「0」が表示されますが構わずフィルドラッグしておいてください。たとえば、12行目まで数式を入れた場合は D:Fの数式は13行目から入力します。 A5:C5に入れた式の $A$3 となっている部分を $D$3 に変更した式を入れて下さい。下に12行分フィルドラッグすると、13行目からは D3セルに入力されているブック名の A1セルに入力されているシート名の B,D,H列の値がそれぞれ参照出来ます。次に、H5セルに =IF(A5=0,"",A5&"_"&B5&"_"&C5) として、12行目までフィルドラッグ I13セルに =IF(D5=0,"",D5&"_"&E5&"_"&F5) として、12行分フィルドラッグまだ数式の入っていないG5セルには =IF((A5=0)*(D5=0),1,COUNTIF($I$5:$I$21,H5)*(H5<>"")+COUNTIF($H$5:$H$21,I5)*(I5<>"")) の式を入れて、21行目までフィルドラッグ。結果は↓の様になります。 [A] [B] [C] [D] [E] [F] [G] [H] [I] [1] AAA [2] [3] 1月 2月 [4] 部品個数種類部品個数種類確認 1月 2月 [5] A 1 aa 1 A_1_aa [6] B 2 aa 1 B_2_aa [7] C 1 aa 1 C_1_aa [8] D 1 ab 1 D_1_ab [9] E 1 aa 1 E_1_aa [10] F 1 aa 1 F_1_aa [11] 0 0 0 1 [12] 0 0 0 1 [13] A 1 aa 1 A_1_aa [14] B 2 aa 1 B_2_aa [15] C 1 aa 1 C_1_aa [16] D 1 ab 1 D_1_ab [17] E 1 aa 1 E_1_aa [18] G 1 ac 0 G_1_ac [19] F 1 aa 1 F_1_aa [20] 0 0 0 1 [21] 0 0 0 1 G列にオートフィルタを設定し、1以外の行を表示させて下さい。重複したものは一致していても表示されますので、あとは確認してください。＞データは最大300くらいです。という事なので、シート一枚くらいなら300行分ずつ数式をコピーしておいてもなんとかなりそうに思います。 A1セルに入力規則でリストを設定するなどして 1.二つのブック名を入力 2.A1セルの値を変更 3.オートフィルタで「1」以外を選択 4.結果を確認 5.A1セルの値を変更 6.オートフィルタで「1」以外を選択 7.結果を確認・・・・・を繰り返してもらえれば良いと思います。ボタンを押したらマクロでポンというわけにはいきませんが、最初の状態よりは簡単に確認できるようになると思いますしここまで設定しておいて、自動化出来そうな所はマクロを勉強なさって自動化してもらえば良いと思います。 (HANA) ---- > 仕事でデータの差異を確認しています。 > 例えばですが1月の売上ファイルにシートが1〜31日まであったとします。 > 1月の売上というファイルにシートごとに機械名がついているとします。 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ > 例えばですが1月の売上ファイルにシートが1〜31日まであったとします。 ^^^^^^^^^^^^^^^^^^^^^^^^^ > そこにaとbという組み合わせのセット品があったとして、 > 2月の同じ日の売上にaとbという組み合わせがあるか調べるのに ^^^^^^^^^^^^^^^^^ 何がどのようになっているのでしょう? シートのレイアウト（日付位置）さえ判明すれば、VBAで簡単に求められるのでは? (seiya) ---- いろいろ教えていただき、ありがとうございます。 VBAの本を見ても、何を使い何を参照にしていいかよくわからなくて、質問しました。会社からデータを持ち出せなくてうまく質問の意図を説明できなかったのにお付き合いくださり、感謝しております。うまく入力できなかったものを見直してきちんと入力しなおしてなんとかやってみようと思います。やはり、マクロをつかって調べたいので・・・。差異があるものだけ、今迄のように関数を入れて見直したいと思っております。これまでは、（1月） A B C D E F G H 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa 4 B b 2 〒 * aa 5 C c 1 い〒 * aa 6 D d 1 い〒 * ab 7 E e 1 あ〒 * aa 8 F f 1 あ〒 * aa 9 : : : : : : : （2月） A B C D E F G H 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa 4 B b 3 〒 * aa 5 C c 1 い〒 * aa 6 D d 1 い〒 * ab 7 E e 1 あ〒 * aa 8 F f 1 あ〒 * aa 9 : : : : : : : とあると、1月のI列に =IF([2月.xlsx]機械!$B3&[2月.xlsx]機械!$D3&[2月.xlsx]機械!$H3=B3&D3&H3,"○") と入力して、差異を調べていました。それを各シートごとに、となると時間がかかるので（一つのブックに40シートくらいあるので）マクロでなんとか全シート一気にできる方法はないものかと思って質問しました。これまでの方法の結果だと、 A B C D E F G H I 1 機械名 2 部品品名個数業者名住所備考種類 3 A a 1 あ〒 * aa ○ 4 B b 2 〒 * aa False 5 C c 1 い〒 * aa ○ 6 D d 1 い〒 * ab ○ 7 E e 1 あ〒 * aa ○ 8 F f 1 あ〒 * aa ○ 9 : : : : : : : : となっていました。差異の多くは部品が増えてる場合が多いのでfalseになるたび式の行を変更してやっていました。おそらく、IFより、VLOOKを使うほうがよかったのかもしれませんが・・・。関数をひとつずつシートごとにいれずに、一気に結果を出したかったのですが・・。最初からきちんと説明できればよかったのですが・・。シート一括に、という方法はマクロを使えばできるんでしょうか。（まんまる） ---- 提示レイアウトに機械名 AAA がありましたね...失礼しました。こんなのはどうでしょう? Sub test() Dim wb1 As Workbook, wb2 As Workbook, ws As Worksheet Dim a, i As Long, ii As Long, z As String, e, x As Long Dim Matched() As String, m As Long Dim NotMatched() As String, nm As Long Dim NotInBoth() As String, nib As Long ReDim Matched(1 To 5000, 1 To 5), NotMatched(1 To 5000, 1 To 10) ReDim NotInBoth(1 To 20000, 1 To 10) Set wb1 = Workbooks("もとのブック名.xls") '<- 実際のファイル名に変更 Set wb2 = Workbooks("他のブック.xls") '<- 実際のファイル名に変更 On Error Resume Next Application.DisplayAlerts = False wb1.Sheets("結果").Delete Application.DisplayAlerts = True On Error GoTo 0 With CreateObject("Scripting.Dictionary") For Each ws In wb1.Sheets If IsSheetExists(ws.Name, wb2.Name) Then '<-修正 a = ws.Range("a1", ws.Cells.SpecialCells(11)).Value For i = 3 To UBound(a, 1) z = a(1, 1) & ";" & a(i, 2) & ";" & a(i, 8) .item(z) = VBA.Array(a(i, 4), _ Array(ws.Name, a(i, 1), a(i, 2), a(i, 8), a(i, 4)), 1) Next With wb2.Sheets(ws.Name) a = .Range("a1", .Cells.SpecialCells(11)).Value End With For i = 3 To UBound(a, 1) z = a(1, 1) & ";" & a(i, 2) & ";" & a(i, 8) If .exists(z) Then w = .item(z) If w(2) <> 0 Then If w(0) = a(i, 4) Then m = m + 1 For ii = 1 To 5 : Matched(m, ii) = w(1)(ii - 1) : Next Else nm = nm + 1 For ii = 1 To 5 : NotMatched(nm, ii) = w(1)(ii - 1) : Next NotMatched(nm, 6) = ws.Name NotMatched(nm, 7) = a(1, 1) NotMatched(nm, 8) = a(i, 2) NotMatched(nm, 9) = a(i, 8) NotMatched(nm, 10) = a(i, 4) End If w(2) = 0 : .item(z) = w End If Else .item(z) = VBA.Array(a(i, 4), _ Array(ws.Name, a(i, 1), a(i, 2), a(i, 8), a(i, 4)), 2) End If Next End If For Each e In .items If e(2) <> 0 Then nib = nib + 1 : x = 0 For ii = IIf(e(2)=1, 1, 6) To IIf(e(2)=1,5, 10) x = x + 1 NotInBoth(nib, ii) = e(1)(x - 1) Next End If Next .removeall Next End With wb1.Sheets.Add.Name = "結果" With wb1.Sheets("結果").Cells(1) .Value = "Match" .Offset(, 5).Value = "数量に差" .Offset(, 15).Value = "単月のみに存在" If m > 0 Then .Offset(1).Resize(m, 5).Value = Matched If nm > 0 Then .Offset(1, 5).Resize(nm, 10).Value = NotMatched If nib > 0 Then .Offset(1, 15).Resize(nib, 10).Value = NotInBoth End With End Sub Function IsSheetExists(ByVal wsName As String, _ Optional wbName As String) As Boolean If IsMissing(wbName) Then wbName = ThisWorkbook.Name On Error Resume Next IsSheetExists =(Workbooks(wbName).Sheets(wsName).Name = wsName) End Function (seiya) 12:28 修正 ---- > シートのレイアウト（日付位置）さえ判明すれば、VBAで簡単に求められるのでは? 先の(HANA)さんのコードでの不具合（それも、自宅ではうまくいったが会社ではダメ）の原因もはっきりとしていないようですし、問題はやはり > 会社に自宅からデータを持って行けないので、コードをプリントして打ち込みましたが、 > うまくいきませんでした。どこか、間違っているようなのですが、 > 何回見直しても間違っているところがわかりませんでした。 > コピーして家でやるとうまくいくので、やはり、私が打ち間違えているのだと思います。という一点に尽きるような・・・（とおりすがり） ---- > という一点に尽きるような・・・別案で提示しただけなので、HANAさんのコードと比較しているわけでもなく同じことをしているわけでもなく... どのような理由で私のコメントをQuoteしたのか知らないけど、評論家のようなコメントだけでなく建設的な解決作を提示してもらいたい。 (seiya) ---- 教えていただきありがとうございます! さっそくしてみたのですが、 If IsSheetExists(ws.Name, wb2.Name)) Thenの部分が構文エラーとでました・・・。どうして間違っているのか、とかぜんぜんわからなくて・・・。お恥ずかしい限りです。基礎からきちんと勉強したいのでマクロの本でお勧めあったら教えていただけませんか? （まんまる） ---- まんまるさん )がひとつ多すぎました If IsSheetExists(ws.Name, wb2.Name) Then コードを修正しました (seiya) ---- ＞先の(HANA)さんのコードでの不具合は、コードの転記ミスかもしれませんしデータ自体が違うかもしれません。そのあたりはよくわからないですね。。。＞うまく入力できなかったものを見直してきちんと入力しなおしてなんとかやってみようと思います。ということですが、これまでのコードは「○○の種類で」を限定するので入力するのは時間の無駄です。上で載せた関数で行ったのと同じ様な結果で良ければこんなコードで出来ると思いますのでこちらを試していただければと思います。シート毎に、一致しないものだけを取り出します。 '------ Sub 検索() Dim dic1 As Object, dic2 As Object Dim wbn1 As String, wbn2 As String Dim tbl, x, y, r, ky Dim dk As String Dim i As Long, ii As Long Dim xi As Long, rc As Long, rr As Long If Workbooks.Count > 4 Then MsgBox "不要ブックは閉じてください。" Exit Sub End If If Workbooks.Count < 3 Then MsgBox "検索するブックを開いてください。" Exit Sub End If Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For Each y In Workbooks If y.Name <> ThisWorkbook.Name Then If wbn1 = "" Then wbn1 = y.Name Else wbn2 = y.Name End If End If Next With Workbooks(wbn1) For i = 1 To .Sheets.Count With .Sheets(i) If .Range("H" & Rows.Count).End(xlUp) > 2 Then tbl = .Range("B3", .Range("H" & Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) dk = .Name & "_" & tbl(ii, 1) & "_" & tbl(ii, 3) & "_" & tbl(ii, 7) dic1(dk) = dic1(dk) + 1 dic2(dk & "_" & dic1(dk)) = wbn1 Next End If End With Next End With Set dic1 = CreateObject("scripting.dictionary") With Workbooks(wbn2) For i = 1 To .Sheets.Count With .Sheets(i) If .Range("H" & Rows.Count).End(xlUp) > 2 Then tbl = .Range("B3", .Range("H" & Rows.Count).End(xlUp)) For ii = 1 To UBound(tbl, 1) dk = .Name & "_" & tbl(ii, 1) & "_" & tbl(ii, 3) & "_" & tbl(ii, 7) dic1(dk) = dic1(dk) + 1 If dic2.exists(dk & "_" & dic1(dk)) Then dic2.Remove (dk & "_" & dic1(dk)) Else dic2(dk & "_" & dic1(dk)) = wbn2 End If Next End If End With Next End With ReDim x(1 To Rows.Count, 1 To 6) For Each ky In dic2 y = Split(ky, "_") xi = xi + 1 x(xi, 1) = dic2(ky) For i = 0 To 3 x(xi, i + 2) = y(i) Next Next With ThisWorkbook.Sheets(1) .Range("A:G").ClearContents If xi > 0 Then With .Range("A1").Resize(xi, 6) .Value = x .Sort Key1:=.Range("B1"), Order1:=xlAscending, Key2:=.Range("A1"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal tbl = .Value End With ReDim r(1 To Rows.Count, 1 To 7) r(1, 1) = "確認日" r(1, 2) = Date r(2, 2) = wbn1 r(2, 5) = wbn2 r(3, 1) = "シート名" r(4, 1) = tbl(1, 2) For i = 1 To UBound(tbl, 1) rr = rr + 1 If i > 1 Then If tbl(i, 2) <> tbl(i - 1, 2) Then r(rr + 3, 1) = tbl(i, 2) End If End If If tbl(i, 1) = wbn1 Then rc = 1 Else rc = 4 End If For ii = 1 To 3 r(rr + 3, rc + ii) = tbl(i, ii + 2) Next Next .Range("A1").Resize(rr + 3, 7) = r .Range("B3:D3,E3:G3") = Array("部品", "個数", "種類") Else MsgBox "差異なし" End If End With Set dic1 = Nothing Set dic2 = Nothing End Sub '------ ちなみに、seiyaさんのは 1. NotInBoth(nib, ii) = e(1)(ii - 1) インデックスが有効範囲にありませんと出ます。 nib = 1 , ii = 6 (HANA) ---- > ちなみに、seiyaさんのは > 1. > NotInBoth(nib, ii) = e(1)(ii - 1) > インデックスが有効範囲にありませんと出ます。 > nib = 1 , ii = 6 HANAさん、どうもです。コードを変更しました。 (seiya) ---- To,seiyaさん・・・やっぱり駄目です。同じエラー nib = 1 , ii = 6 , x = 6 (HANA) ---- HANAさん、ありがとございます! うまくできました。会社で明日、やってみます。 HANAさんには本当にながながとご迷惑おかけしました。seiyaさんもありがとうございます。会社でうまくいくかはわかりませんが、今度また質問する機会があったらもう少しマクロについて勉強してきちんと質問できるようになっていたいと思います。本当に、あろがとうございました。（*^_^*）（まんまる） ---- どうやら、うまくいったようですね。とりあえず修正してみました。 Arrayの中身が一つ足りないようです...ws.Name... (seiya) ---- ここでもう私が発言すべきことはない状況のようですが、ひと言だけ。 > 別案で提示しただけなので、HANAさんのコードと比較しているわけでもなく seiyaさんがそのような方でないことはわかっているつもりです。幾通りもの回答が寄せられるところにこそ、このような掲示板の意味があると思います。（「良いところ取り」などと発言された方も、どこかにおられましたが・・・） > という一点に尽きるような・・・というのは、seiyaさんではなく質問者さんへ向けた発言でした。言いたかったのは、質問者さんの再現環境が整わない限り、いずれのコードで試してみても、解決にはかなり時間がかかりそうだということです。言うまでもなく、ここでいう「解決」とは「回答が合っている」ということではなく「質問者の問題が解決するかどうか」ということ。仕事上での問題であれば時間的な縛りもあるだろうし、VBAに拘らずとも解決できる方法があるならそれに頼れば良いのでは?と余計なお節介心が頭をもたげてしまっただけです。（文字通り、お節介でしかなく失礼しました。）なにはともあれ、質問者さんに問題解決の道が見えてきたとのことで良かったです。（とおりすがり） ---- とおりすがりさん私の読解力の無さで失礼な発言をしました。全く同感です。 (seiya) ---- To,seiyaさん済みません。 Array(ws.Name, a(i, 1), a(i, 2), a(i, 8), a(i, 4)) ‾これが抜けているのだとは思いますがそれでも、0〜4までしか無いですよね。元ブックより、その他のブックの方が行数が多い場合（これまでのテストデータ）のときはエラーにならなくなりましたが IFの条件が整わず、この行に入らなくなったので。データを入れ替えると、エラーが出る様です。 (HANA) ---- そうでしたもともと、どちらのファイルのデータかを判別しやすいように Array(wb1.Name, ws.Name, ....), Array(wb2.Name, ws.Name, a(...... ^^^^^^^^ ^^^^^^^^ とする予定が、書いているうちに忘れてしまったのですね。年をとると忘れることが仕事になってしまって.... コードを変更しておきます。 (seiya) それと、 On Error Resume Next から On Error GoTo 0 は loop が始まる前に移動する必要もありました。 ---- To,seiyaさんそれでも・・・ xが7まで行ってしまいます。 (HANA) ---- ですよね... For ii = IIf(e(2)=1, 1, 6) To IIf(e(2)=2,5, 10) ^ は For ii = IIf(e(2)=1, 1, 6) To IIf(e(2)=1,5, 10) ^ でした。 (seiya) ---- To,seiyaさん動く様にはなりましたが。。。。「Sheet1」は私のコードの実行結果「結果」はseiyaさんのコードの実行結果のうち差異データ部分 Sheet1 [A] [B] [C] [D] [E] [F] [G] [1] 確認日 2009/3/29 [2] 1月.xls 2月.xls [3] シート名部品個数種類部品個数種類 [4] AAA F 1 aa [5] G 1 ac [6] A 1 aa [7] BBB F 1 aa [8] H 2 aa [9] I 1 aa [10] I 1 aa [11] G 1 ac [12] A 1 aa [13] H 3 aa [14] I 2 aa [15] I 2 aa [16] CCC G 1 ac [17] A 1 aa [18] F 1 aa 結果 [F] [G] [H] [I] [J] [K] [L] [M] [N] [O] [1] 数量に差 [2] 1月.xls BBB H aa BBB BBB H aa 3 [3] 1月.xls BBB I aa BBB BBB I aa 2 [P] [Q] [R] [S] [T] [U] [V] [W] [X] [Y] [1] 単月のみに存在 [2] 1月.xls AAA [3] 2月.xls AAA G ac [4] 2月.xls BBB G ac [5] 1月.xls CCC G ac ・・・・抜けている所があるんですよね。 9,10,14,15行目（I）のパターンのデータはありえなさそうですが。（数量違いの同じデータが二つずつある） 4,6行目（F,A）は片方にデータが一つもう片方に同じデータが二つあるパターンです。 5行目（G）は純粋に片方にあって、片方に無いパターンです。とりあえず、今はそんな感じの元データでやっています。 (HANA) ---- いろいろ修正しているうちに余計なところまで「修正」してしまったようです。少し変更しました。 > 数量違いの同じデータが二つずつあるえーーと、このパターンには対応していません。すでにお分かりのように、私のコードは [部品] - [組み合わせ] でユニークであると想定しています。そこでマッチしたものに対して、数量のマッチしたもの、しなかったもの、マッチせず単一シートのみに出現したものを抽出する（予定では）ようにしたつもりです。 (seiya) ---- To,seiyaさん無事に動きました。＞すでにお分かりのように、私のコードは [部品] - [組み合わせ] でユニークである＞と想定しています。そうですね、私もこれは先に確認しておけばよかったと思いながらコードを書いていました。すると、横に並べるのもコードに組み込めたのですが。。。 (HANA) ---- HANAさん、長々とお付き合いいただきましてありがとうございました。 (seiya) ...; http://www.excel.studio-kazu.jp/wiki/kazuwiki/200903/20090303194225.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ