『再質問！重複レコードテーブルの検索と切り取りと貼り付け』（助けて） マクロを初めてまだ未熟なもので助けてください。 ”『マクロで一致するデータの切り取り、貼り付け処理』（左利き）”さんの質問の もっと複雑な質問です。 [sheet1] [sheet2] |--------------------| |-----------| | date | no | name | | date | no | |--------------------| |-----------| | 8/1 | 1 | tanaka | | 8/1 | 7 | | 8/1 | 2 | | | 8/2 | 4 | | 8/2 | 4 | | | 8/3 | 5 | | 8/2 | 4 | sasaki | | 8/4 | 6 | | 8/2 | 4 | sasaki | |-----------| | 8/1 | 3 | noda | | 8/4 | 6 | | |--------------------| 上記のようなsheet1とsheet2があります。 これをマッチングして下記のようにsheet3とsheet4に編集したいのです。 どうか、お助けください。 [sheet3] [sheet4] |--------------------| |--------------------------| | date | no | name | | date | no | err | name | |--------------------| |--------------------------| | 8/1 | 1 | tanaka | | 8/1 | 7 | err | | | 8/1 | 2 | | | 8/2 | 4 | ok | | | 8/1 | 3 | noda | | 8/2 | 4 | ok | sasaki | |--------------------| | 8/2 | 4 | ok | sasaki | | 8/3 | 5 | err | | | 8/4 | 6 | ok | | |--------------------------| 本当はもっと複雑なんですけど、このサンプルをベースに勉強していきたいと 考えております。 どうかよろしくお願い申し上げます。 ---- Sheet3の結果はなぜ8/1だけ？ それと、まだVBAを始めたばかりならサンプルは省力しないで提示したほうが がいいと思いますよ？ (seiya) ---- seiyaさん　ありがとうございます。 取り急ぎ、サンプルで十分です。 あと、説明不足で申し訳ございません。 sheet1でマッチングしたレコードは削除したいのです。 ---- Sheet3がわからないのですが？ (seiya) ---- 申し訳ございません。 sheet3はsheet1でマッチングしなかったレコードをコピーしたものです。 やっぱり、複雑なサンプルも掲載させていただきます。 [sheet1] [sheet2] |----------------------------| |-----------| | date | no | name | suryo | | date | no | |----------------------------| |-----------| | 8/1 | 1 | tanaka | 1 | | 8/1 | 7 | | 8/1 | 2 | | 1 | | 8/2 | 4 | | 8/2 | 4 | | 1 | | 8/3 | 5 | | 8/2 | 4 | sasaki | 2 | | 8/4 | 6 | | 8/2 | 4 | sasaki | 1 | |-----------| | 8/1 | 3 | noda | 1 | | 8/4 | 6 | | 1 | |----------------------------| 上記のようなsheet1とsheet2があります。これをマッチングして下記のようにsheet3とsheet4とsheet5に編集したいのです。どうか、お助けください。 [sheet3] [sheet4] [sheet5] |----------------------------| |----------------------------------| |-------------------| | date | no | name | suryo | | date | no | err | name | suryo | | date | no | gokei | |----------------------------| |----------------------------------| |-------------------| | 8/1 | 1 | tanaka | 1 | | 8/1 | 7 | err | | | | 8/2 | 4 | 4 | | 8/1 | 2 | | 1 | | 8/2 | 4 | ok | | 1 | | 8/4 | 6 | 1 | | 8/1 | 3 | noda | 1 | | 8/2 | 4 | ok | sasaki | 2 | |-------------------| |----------------------------| | 8/2 | 4 | ok | sasaki | 1 | | 8/3 | 5 | err | | | | 8/4 | 6 | ok | | 1 | |----------------------------------| sheet5はsheet1でマッチングokだったレコードより"date""no"が等しいレコードのsuryo合計を算出した レコードです。 ---- うまく動くことを期待して... Sub test() Dim a, b(), i As Long, ii As Long, n As Long, t As Long, w() Dim dic As Object, z As String, e As Variant, x, UB As Long Set dic = CreateObject("Scripting.Dictionary") With Sheets("Sheet2") a = .Range("a1",.Range("a" & Rows.Count).End(xlUp)).Resize(,2).Value End With For i = 1 To UBound(a,1) dic.add a(i,1) & ";" & a(i,2), "err" Next With Sheets("sheet1") a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,4).Value End With ReDim b(1 To UBound(a,1), 1 To UBound(a,2)) For i = 1 To UBond(a,1) z = a(i,1) & ";" & a(i,2) If Not dic.exists(z) Then n = n + 1 For ii = 1 To UBound(a,2) : b(n,ii) = a(i,ii) : Next '<- 1) ここです Else If IsArray(dic(z)) Then '<- 3) このようにしてみました w = dic(z) : UB = UBound(w,2) + 1 Else UB = 1 End If ReDim Preserve w(1 To 5, 1 To UB) For ii = 1 To 4 w(IIf(ii<=2,ii,ii+1),UB) = a(i,ii) Next w(3,UB) = "ok" dic(z) = w End If Next y = dic.items If n > 0 Then _ Sheets("sheet3").Range("a1").Resize(n,UBound(b,2)).Value = b n = 0 With Sheets("sheet4").Range("a1") For i = 0 To Ubound(y) If IsArray(y(i)) Then .Offset(n).Resize(UBound(y(i),2),UBound(y(i),1)).Value = _ Application.Transpose(y(i)) n = n + UBound(y(i),2) + 1 Else .Offset(n).Value = y(i) n = n + 1 End If Next End With dic.removeall a = Sheets("sheet4").Range("a1").CurrentRegion.Value Sheets("sheet5").Range("a1").Resize(,3).Value = [{"date","no","gokei"}] n = 1 For i = 2 To UBound(a,2) z = a(i,1) & ";" & a(i,2) If a(i,3) = "ok" Then If Not dic.exists(z) Then n = n + 1 Sheets("sheet5").Cells(n,1).Resize(,3) = Array(a(i,1),a(i,2),a(i,5)) dic.add z, n Else x = dic(z) With Sheets("sheet5").Cells(x,3) .Value = .Value + a(i,5) End With End If End IF Next End Sub (seiya) 修正 12:14 ---- seiyaさん　ありがとうございます。 今から仕事に行きますので、明日、早速やってみたいと思います。 本当、感謝してます。 ---- seiyaさん、見て居られますでしょうか？ 動かないので、教えてもらいたいのですが ０．For i = 1 To UBond(a,1) 　　　→UBound(a,1) 　　として １．For ii = 1 To UBound(a,2) : b(n,ii) = a(i,ii) 　　の　Next　は、すぐ下で良いですか？ ２．For Each e In dic.keys 　　の　Next　は、どこに入れますか？ ↑を適当に入れて ３．ReDim Preserve w(1 To 5, 1 To UB) 　　で　コンパイルエラー「ReDim　が無効です」でとまります。 ここをコメント化すると ４．UB = IIf(IsArray(w) = True, UBound(w, 2) + 1, 1) 　　で、実行時エラー13「型が一致しません」がでます。 　　　この時 w の値は "err" ですが・・・。 よろしくお願いします。 (HANA) ---- HANAさん、ありがとうございます。 修正してみました。 3) は　4) でUBが取得できてないのでその結果エラーになるのだと思います。 (seiya) ---- たぶん、コードが走る前に「３が駄目！！」って言われてます。 黄色いマーカーが、名前の所から動かないので・・・。 こんな言葉で何か思いつきますか？ ３は相変わらず、コメント化で（これがいけないんですって？） 変えてもらった所（４）は動くのですが 次の ＞w(IIf(ii <= 2, ii, ii + 1), UB) = a(i, ii) でとまります。 やっぱり３が問題っぽいですが・・・。 (HANA) ---- いけね、動的配列変数　Dim w() を入れないといけませんね。 (seiya) ---- 実行時エラー13「型が一致しません」 w = dic(z) です。 この部分は、何をしている所なのですか？ (HANA) ---- そうですよね... その部分は dic(z) に格納した "err" または 配列 を w に代入しているのですが、 "err"　の時は "型" が違いますね... 修正しました。 P.S.　本日はこれで落ちますので... HANAさん、ありがとうございました！ (seiya) ---- おぉっ、動きました。 ＞Sheets("sheet3").Range("a1").Resize(n,UBound(b,2)).Value = b でとまりますが・・・。 ちなみに、実行時エラー1004 　「アプリケーション定義またはオブジェクト定義のエラーです」 だそうです。 地道に移動させてますが取り敢えず動いたので 載せてみます。（結局一つずつ見てるんですよね。） Sub QQ() Dim dic1 As Object, dic2 As Object Dim i As Long, ii As Long, xr As Long, yr As Long, zr As Long, cc As Long Dim s As String Dim x, y, z, tbl1, tbl2 '★★★１★★★★★★★ Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") tbl1 = Sheets("Sheet1").Range("A1").Resize(Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row, 5) tbl2 = Sheets("Sheet2").Range("A1").Resize(Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row, 3) ReDim x(1 To UBound(tbl1, 1), 1 To 4) ReDim y(1 To UBound(tbl1, 1) + UBound(tbl2, 1), 1 To 5) ReDim z(1 To UBound(tbl2, 1), 1 To 3) '★★★２★★★★★★★ For i = 1 To UBound(tbl1, 1) s = tbl1(i, 1) & "♪" & tbl1(i, 2) dic1(s) = dic1(s) + tbl1(i, 4) Next For i = 1 To UBound(tbl2, 1) dic2(tbl2(i, 1) & "♪" & tbl2(i, 2)) = Empty Next '★★★３★★★★★★★ For cc = 1 To 4 x(1, cc) = tbl1(1, cc) Next xr = 1 '★★★４★★★★★★★ For i = 1 To UBound(tbl1, 1) If Not dic2.exists(tbl1(i, 1) & "♪" & tbl1(i, 2)) Then xr = xr + 1 For cc = 1 To 4 x(xr, cc) = tbl1(i, cc) Next End If Next '★★★５★★★★★★★ For i = 1 To UBound(tbl2, 1) s = tbl2(i, 1) & "♪" & tbl2(i, 2) If Not dic1.exists(s) Then '★★★５−１−１★★★ yr = yr + 1 For yc = 1 To 3 y(yr, yc) = IIf(yc < 3, tbl2(i, yc), "err") Next Else '★★★５−２★★★★★ zr = zr + 1 For ii = 1 To UBound(tbl1, 1) If s = tbl1(ii, 1) & "♪" & tbl1(ii, 2) Then '★★★５−１−２★★★ yr = yr + 1 For cc = 1 To 5 y(yr, cc) = IIf(cc <> 3, tbl1(ii, IIf(cc < 3, cc, cc - 1)), IIf(yr = 1, "err", "ok")) Next '★★★５−３★★★★★ For cc = 1 To 3 z(zr, cc) = IIf(cc < 3, tbl1(ii, cc), IIf(zr = 1, "gokei", dic1(s))) Next End If Next End If Next '★★★６★★★★★★★ Sheets("Sheet3").Cells.ClearContents Sheets("Sheet3").Range("A1").Resize(xr, 4) = x Sheets("Sheet4").Cells.ClearContents Sheets("Sheet4").Range("A1").Resize(yr, 5) = y Sheets("Sheet5").Cells.ClearContents Sheets("Sheet5").Range("A1").Resize(zr, 3) = z '★★★７★★★★★★★ Set dic1 = Nothing Set dic2 = Nothing End Sub seiyaさん、明日はたぶんこれませんので 明日以降　もう少しお願いします。 ~~~~ ↑明後日！！　ですね。（汗） (HANA) ---- HANAさん、 そうですか、私は明日（月曜日）は登校できませんので火曜日以降になります。 一応変更してみます。 考えられる原因は n = 0の場合ですが、そんなことあるのかなーー... (seiya) ---- seiyaさん、HANAさん　本当にお忙しい中　ありがとうございます。 今までＶＢＡに興味はあったのですが、古い人間なものですから、ちょっと抵抗がありました。 最近、勉強を始めて、面白くなってもっと詳しく知ろうと思い立ったのです。 今回、このサンプルをベースに努力していきたいと思います。 これからも、よろしくお願い申し上げます。 ---- ＞（結局一つずつ見てるんですよね。） をなんとかしたくてやってみましたが 早さがほとんど変わらないのは、その後の ＞地道に移動 が問題なのか・・・。 Sub QQ2() Dim dic1 As Object, dic2 As Object Dim i As Long, ii As Long Dim xr As Long, yr As Long, tr As Long, rr As Long Dim yc As Long, cc As Long Dim s As String Dim m, x, y, tbl1, tbl2 Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") tbl1 = Sheets("Sheet1").Range("A1").Resize(Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row, 5) tbl2 = Sheets("Sheet2").Range("A1").Resize(Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row, 3) For i = 2 To UBound(tbl1, 1) s = tbl1(i, 1) & "♪" & tbl1(i, 2) If Not dic1.exists(s) Then dic1(s) = 1 Else dic1(s) = dic1(s) + 1 End If Next For Each m In dic1.items yc = IIf(yc < m, m, yc) Next For i = 2 To UBound(tbl2, 1) On Error Resume Next dic2.Add tbl2(i, 1) & "♪" & tbl2(i, 2), i Next ReDim x(1 To UBound(tbl1, 1), 1 To 4) ReDim y(1 To UBound(tbl2, 1), 1 To yc + 2) For cc = 1 To 4 x(1, cc) = tbl1(1, cc) Next xr = 1 For i = 2 To UBound(tbl1, 1) s = tbl1(i, 1) & "♪" & tbl1(i, 2) If dic2.exists(s) Then ii = dic2(s) y(ii, 1) = y(ii, 1) + 1 y(ii, 2) = y(ii, 2) + tbl1(i, 4) y(ii, y(ii, 1) + 2) = i rr = IIf(y(ii, 1) > 1, rr + 1, rr) Else xr = xr + 1 For cc = 1 To 4 x(xr, cc) = tbl1(i, cc) Next End If Next With Sheets("Sheet3") .Cells.ClearContents .Range("A1").Resize(xr, 4) = x End With ReDim x(1 To rr + UBound(tbl2, 1), 1 To 5) For cc = 1 To 5 x(1, cc) = IIf(cc = 3, "err", tbl1(1, IIf(cc < 3, cc, cc - 1))) Next xr = 1 rr = 0 For i = 2 To UBound(y, 1) If y(i, 1) = Empty Then xr = xr + 1 For cc = 1 To 3 x(xr, cc) = IIf(cc = 3, "err", tbl2(i, cc)) Next Else rr = rr + 1 For ii = 1 To y(i, 1) tr = y(i, ii + 2) xr = xr + 1 For cc = 1 To 5 x(xr, cc) = IIf(cc = 3, "ok", tbl1(tr, IIf(cc < 3, cc, cc - 1))) Next Next End If Next With Sheets("Sheet4") .Cells.ClearContents .Range("A1").Resize(xr, 5) = x End With ReDim x(1 To rr + 1, 1 To 3) For cc = 1 To 3 x(1, cc) = IIf(cc = 3, "gokei", tbl1(1, cc)) Next xr = 1 For i = 2 To UBound(y, 1) If y(i, 1) > 0 Then xr = xr + 1 For cc = 1 To 3 x(xr, cc) = IIf(cc = 3, y(i, 2), tbl2(i, cc)) Next End If Next With Sheets("Sheet5") .Cells.ClearContents .Range("A1").Resize(xr, 3) = x End With Set dic1 = Nothing Set dic2 = Nothing End Sub (HANA) ---- To seiyaさん 動きましたが結果が以下の様になります。 　 Sheet3 なし 　 Sheet4 [A] [B] [C] [D] [E] [F] [1] date no ok suryo #N/A [2] date no ok suryo #N/A [3] err [4] 8/2 4 ok 1 #N/A [5] 8/2 4 ok 2 #N/A [6] 8/2 4 ok 1 #N/A [7] #N/A #N/A #N/A #N/A #N/A #N/A [8] err [9] 8/4 6 ok 1 #N/A [10] 8/4 6 ok 1 #N/A 　 Sheet5 [A] [B] [C] [1] date no gokei [2] date no suryo [3] 8/2 4 4 以上、ご報告まで。 以下、自己削除します。 もう少し、いろいろ遊んでみますね。 有り難う御座いました。 (HANA) ---- おお、 HANAさん、どうもです。 結果はHANAさんのコードですか？ (seiya) ---- 残念ながら、seiyaさんのコードです。 >If ii <> 3 Then w(IIf(ii<=2,ii,ii+1),UB) = a(i,ii) この部分で　ii=3（名前の列）がとんでしまうのと >.Offset(n).Resize(UBound(y(i),2)+1,UBound(y(i),1)+1).Value この部分で範囲が+1されてしまう あとは、Sheet2にはあるがSheet1に無い場合 dicのitemに　"err"しか入っていないかと・・・。 基本的には、いろいろやって seiyaさんのお話＆骨格（dicのitemに配列として入れておく） で、求める結果は得られたのですが 分からなかったのは、nに関して、直前で ＞n = 0 : y = dic.items としているので ＞If n > 0 Then の方には行かないと思うのですが・・・・？ (HANA) ---- 1) 勘違いしていました、変更済み 2) これもそうですね、変更済み 3) まったく間抜けをしていますね、位置を変更しました。 (seiya) ---- 「n=0」は、その位置に入るのですね。 結果が気になって居られると思いますので・・・ （別に気になっておられませんかね？ 　でしたら、スルーして下さい。） Sheet3 [A] [B] [C] [D] [1] 8/1 1 tanaka 1 [2] 8/1 2 1 [3] 8/1 3 noda 1 　 Sheet4 [A] [B] [C] [D] [E] [1] date no ok name suryo [2] [3] err [4] 8/2 4 ok 1 [5] 8/2 4 ok sasaki 2 [6] 8/2 4 ok sasaki 1 [7] [8] err [9] 8/4 6 ok 1 こうなります。 私としてはいろいろ収穫があったのですが、以前 [[20070422115835]]『またお助けください』（ちょいボケ親父） さんが「転記先で日付が反対になる」2007/4/22 → 22/4/2007 と仰って居られた現象が、おきました。 なぜか、文字列になって出てきます。 文字列なので「Format」で変わらなかったのかな・・・？と。 TRANSPOSEで取り出した日付は（Sheet4）、シリアル値になっています。 バージョンは2002ですが、そう言う問題でも無いような・・・？ (HANA) 　 ---- ---- 削除された書き込みを復元(ここから)[kazu]2007/09/17 03:38 ---- ---- 2007/4/22 -> 22/4/2007 Windowsの日付の設定はどのようになっていますか？ その設定が反映されているような気がするのですが... (seiya) ---- 「Windowsの日付の設定」 と言うと、 　コントロールパネル→地域と言語のオプション 　　　[ 地域オプション ]タブ ですかね？ 　短い形式[ 2007/08/22 ] 　長い形式[ 2007年8月22日 ] なんですよね。 違う所ですかね？ (HANA) ---- そうですか... US format は mm/dd/yyyy　のはずですから、どうしてでしょうね？ PasteSpecialで xlPasteFormats でしょうかね？ (seiya) ---- そ・・・それが、駄目なんですよ。 文字列として入っているので、表示形式では変わらないのです。 （形式を選択して貼り付け → 書式　のコードですよね？） しかも、あんなに勝手に文字列を数値にしてくれる エクセル君が「22/8/2007」に関しては あくまでも文字列だ　と言うのです。 「--"22/8/2007"」を「#VALUE!」と言うのです。 たとえば、A1に日付を入れて =--TEXT(A1,"yyyy/m/d") はエラーになりませんが =--TEXT(A1,"m/d/yyyy") はエラーになります。 でも、TRANSPOSEで取り出せば日付なのですよね・・・。 (HANA) ---- Hummmm 最後の手段はUDFで無理やり修正しますか？ 配列の中で処理しても、出力してから処理しても... こんな感じで For Each r In Sheets("sheet3").Range("a1").CurrentRegion.Resize(,1) r.Value = ChangeOrder(r) Next Function ChangeOrder(txt As String) As Date With Createobject("VBScript.RegExp") .Pattern = "(\d(1,2})/(\d{1,2})/(\d{4})" If .test(txt) Then ChangeOrder = CDate(.replace(txt,"$3/$2/$1")) End If End With End Function (seiya) ---- 「出力して変換」なら Sub TEST() Dim R For Each R In Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 1) R.Value = DateValue(Year(R) & "/" & Month(R) & "/" & Day(R)) Next End Sub こんな感じでも出来ました。 「配列の中で処理」と言うのが・・・。 以下の様なコードで　次の結果がでます。 [A] [B] [C] [D] [1] 22/8/2007 2007/8/22 2007/8/22 [2] 23/8/2007 2007/8/23 2007/8/23 Sub TEST() Dim R, S, T As String, i As Long R = Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 1) ReDim S(1 To UBound(R, 1), 1) For i = 1 To UBound(R, 1) T = R(i, 1) S(i, 1) = DateValue(Year(T) & "/" & Month(T) & "/" & Day(T)) Sheets("sheet1").Cells(i, 3) = S(i, 1) Sheets("sheet1").Cells(i, 4) = DateValue(Year(T) & "/" & Month(T) & "/" & Day(T)) Next Sheets("sheet1").Range("B1").Resize(UBound(R, 1), 1) = S End Sub エラーが出るわけでもなく 一つずつなら書き出せるのに 最後にB列に書き出せないのがどうしてなのか分かりません。 何か必要なのでしょうか？ (HANA) ---- 1) 動的配列の宣言は S() としないで VB から怒られませんか？ 2) A 列は「文字列」ですか？それとも日付で表示形式でそのようにしてあるのですか？ 3) DateValue(a(i,1)) にしたらどうなりますか？ (seiya) ---- 1)怒られないです。 　S() とするのは、どういう意味を持つのですか？ 2)標準のセルに「22/8/2007」と入れると、文字列になります。 ので、文字列です。 3)DateValue(S(i, 1)) = DateValue(Year(T) & "/" & Month(T) & "/" & Day(T)) 　と言う事ですよね？ 　これは「型が一致しません」と怒られます。 (HANA) ---- 1) そうですか...配列として宣言しなくてもよいのですね...失礼しました。 S() は配列変数として宣言するということです。 コード内で Redim statement でサイズを決める配列は動的配列で Dim S(5,100) というように 配列をサイズを含めて宣言した配列 を静的配列といいます。 2) 文字列として配列に格納されているのであれば 3) S(i,1) = DateValue(a(i,1)) でもいけると思ったのですが... (seiya) ---- 1)ReDim Preserveを使わないとして、事前に大きさが分かっている場合 　静的配列にするのと、動的配列にするのとでは 　何か（早さ等）に違いがあったりするのですか？ 2)そっちをかえるのですね。直接セルに書き出すのは上手く行きました。 　配列に入れておいて、最後に・・・ 　ってのは、相変わらず出てきませんが。 そこで（前提もうっかり間違ってましたし） A列シリアル値で入力。 B,C列はシリアル値、E列は文字列で出てきます。 D列は出てきません。 [A] [B] [C] [D] [E] [1] 2007/8/22 2007/8/22 2007/8/22 8/22/2007 [2] 2007/8/23 2007/8/23 2007/8/23 8/23/2007 　 Sub TEST2() Dim R, S, i As Long R = Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 1) ReDim S(1 To UBound(R, 1), 1) For i = 1 To UBound(R, 1) S(i, 1) = R(i, 1) Sheets("sheet1").Cells(i, 2) = S(i, 1) Sheets("sheet1").Cells(i, 3) = R(i, 1) Next Sheets("sheet1").Cells(1, 4).Resize(UBound(R, 1), 1) = S Sheets("sheet1").Cells(1, 5).Resize(UBound(R, 1), 1) = R End Sub 　 B列に出てくるので、入ってない訳ではないと思うのですが・・・。 入れ直す事で、何かが変わってしまうと思われますか？ (HANA) ---- 1) 動的は配列を宣言して　ReDim (Preserve) statementでサイズを決定してやれば、コードが要求する サイズに応じた配列が手に入りますよね？ 2) E列の書式が文字列になっているなんてことは無いですよね？ (seiya) ---- 1)ですから、動的配列で宣言しておいた方が、お得な気がしますが 　「静的配列」と言う物があるからには、その存在意義が何かあるのかと・・・。 2)E列の書式は「日付」です。 　でも、出てきた物は文字列なんです。 　Ｄ列には出てきませんし・・・。 (HANA) 　 ---- 1) は利点かどうかわかりませんが、 動的配列の場合 Erase statement でメモリから開放されますが、静的配列は初期化されるだけだと思いました。 2) ますます不可解ですね... LocalWindowでどのように変換されているか確認でいますか？ (seiya) ---- 1)開放したく無いときは「静的配列」って使い分けですね。 　有り難う御座いました。 2)LocalWindowでどのように・・・ 　あぁぁっ、書き出されない理由は分かりました。 　ごめんなさい。 ＞ReDim S(1 To UBound(R, 1), 1) 　としていたので、データの入っていない 　S(i,0)の方が出力されてました。 　こんな時は 　★ReDim S(1 To UBound(R, 1), 1 To 1) とするのですか？ 　書き出された結果としては、やはり「m/d/yyyy　の文字列」なのですが・・・・。 (HANA) ---- 2) そうですね、 Option Base 1 と宣言していれば添字の最小値は　1 になり、 そうでなければ　0 になります。 ですが、私は混乱を避けるために　To を使用しています。 S(1 To UBound(R,1), 1 To 1) のように (seiya) ---- 「Option Base 1」この文字、どこかでみた気がします。 私の場合、うっかりしないために 「1 To 1」の方が良さそうです。 配列に入っている日付データを、一気にシートに出そうとすると m/d/yyyyの文字列になってしまうんですね。 （今の所、このエクセルと、ちょいボケ親父さんが 　ご使用中のエクセルに関してのみですが。） それにしても、「LocalWindow」初めて使いました。 便利な物があるんですね。（笑） seiyaさん、有り難う御座いました。 又よろしくお願いします。 (HANA) ---- こちらこそ、いつもありがとうございます。 (seiya) ---- どこへ載せようか迷ったのですが http://support.microsoft.com/kb/182812/ja 「Range オブジェクトの Value2 プロパティの説明」 こんな記事を見つけたのでやってみました。 自動翻訳なので、ちょっと意味がよく分からない所もありますが 日付に関する方を抜き出すと 　「Value プロパティは、短い日付形式が設定される日付を返します。 　　日付としてフォーマットされたセルの Value2 プロパティは、 　　日付に基になるシリアル番号を返します。　　　」 セルの書式設定に「日付」「通貨」が設定してあった場合 Valueで取得すると、それなりに変更した数値として取り込む。 （“短い日付形式が設定される日付”　と言うことは、 　この時点で「シリアル値」ではなくなっているのかも？） Value2で取得すると、セルに入力されている値を取り込む。 と、書いてあるのかと。 そこで Sub TEST3() Dim R, S, i As Long R = Range("a1").CurrentRegion.Resize(, 1).Value S = Range("a1").CurrentRegion.Resize(, 1).Value2 With Range("B1") .Resize(UBound(R, 1), 2) = R .Resize(UBound(R, 1), 1).NumberFormat = "yyyy/m/d" End With With Range("D1") .Resize(UBound(S, 1), 2) = S .Resize(UBound(S, 1), 1).NumberFormat = "yyyy/m/d" End With End Sub を実行。↓結果。 [A] [B] [C] [D] [E] [1] 2007/8/22 8/22/2007 8/22/2007 2007/8/22 39316 [2] 2007/8/23 8/23/2007 8/23/2007 2007/8/23 39317 [3] 2007/8/24 8/24/2007 8/24/2007 2007/8/24 39318 [4] 2007/8/25 8/25/2007 8/25/2007 2007/8/25 39319 シリアル Value Value Value2 Value2 値で入力 Format Format セルの書式設定をしておくか、書き出した後に設定する必要がありますが このエクセル君でも、日付を一度に取り出すことが出来ました。 (HANA) ---- HANAさん、おはようございます。 今、原語で読みました。 要約すると Value/Value2 property の違いは Value2 は Date/Currency typeのデータは Double type のデータとして返す。 だそうですので、結構使い道がありそうですね。 (seiya) ---- ---- 削除された書き込みを復元(ここまで) ---- ---- あれから上記のサンプルを参考にして下記のことをしようとしたのですが 理解に苦しんでます。 [sheet1] ----------------------------------------- |a1 |a2 |a3key1 |a4 |a5 |a6 |a7key2 |a8 | |---------------------------------------| |赤 |01 | 001 | 1 | 10| 10| 0101 | 0 | |赤 |02 | 002 | 1 | 10| 10| 0201 | 0 | |赤 |01 | 001 | 1 | 10| 10| 0101 | 0 | |赤 |01 | 001 | 1 | 10| 10| 0102 | 0 | |赤 |03 | 003 | 1 | 10| 10| 0303 | 0 | |赤 |02 | 002 | 1 | 10| 10| 0202 | 0 | ----------------------------------------- [sheet2] ----------------------------- |b1 |b2key1 |b3 |b4key2 |b5 | |---------------------------| |1 | 001 | 1 | 0101 | 20| |2 | 002 | 1 | 0203 | 10| |3 | 002 | 1 | 0202 | 10| ----------------------------- [sheet3] ----------------------------------------- |a1 |a2 |a3key1 |a4 |a5 |a6 |a7key2 |a8 | |---------------------------------------| |赤 |02 | 002 | 1 | 10| 10| 0201 | 0 | |赤 |01 | 001 | 1 | 10| 10| 0102 | 0 | |赤 |03 | 003 | 1 | 10| 10| 0303 | 0 | ----------------------------------------- [sheet4] -------------------------------------------------------------------------- |b1 |b2key1 |b3 |b4key2 |b5 |結果|a1 |a2 |a3key1 |a4 |a5 |a6 |a7key2 |a8 | |------------------------------------------------------------------------| |1 | 001 | 1 | 0101 | 20| ok |赤 |01 | 001 | 1 | 10| 10| 0101 | 0 | |1 | 001 | 1 | 0101 | 20| ok |赤 |01 | 001 | 1 | 10| 10| 0101 | 0 | |2 | 002 | 1 | 0203 | 10| err| | | | | | | | | |3 | 002 | 1 | 0202 | 10| ok |赤 |02 | 002 | 1 | 10| 10| 0202 | 0 | -------------------------------------------------------------------------- [sheet5] -------------------------------------------------------------- |a1 |a2 |a3key1 |a7key2 |a8 |合計|b1 |b2key1 |b3 |b4key2 |b5 | |------------------------------------------------------------| |赤 |01 | 001 | 0101 | 0 | 20|1 | 001 | 1 | 0101 | 20| |赤 |02 | 002 | 0202 | 0 | 10|3 | 002 | 1 | 0202 | 10| -------------------------------------------------------------- 上記のsheet1とsheet2のシートが存在します。 上記のsheet3とsheet4とsheet5は空シートです。 sheet1とsheet2を"key1""key2"でマッチングします。 マッチングしなかったsheet1は、sheet3へコピーします。 マッチングしなかったsheet2は、sheet4へコピーして 結果項目欄に"err"と表示します。 マッチングしたsheet2は、sheet2の内容とsheet1の内容をsheet4へコピーして 結果項目欄に"ok"と表示します。 マッチングしたsheet1は、sheet1の内容とsheet2の内容をsheet5へコピーして "key1""key2"で名寄せしてa6の合計を算出後、合計項目欄に表示します。 前回のVBAと比較しながら理解しようと思います。 どうか、よろしくお願い申し上げます。 (助けて) ---- 回答ではないですが。 タイトルを変更までされるのなら、新しくスレを立てて過去ログをリンクで貼っておくのが 見易いかと。 随分下まで来てますし。 >あれから上記のサンプルを参考にして下記のことをしようとしたのですが >理解に苦しんでます。 どのようなコードが出来て、どの部分がうまくいかないのか提示されては？ >前回のVBAと比較しながら理解しようと思います。 今回のものと比較するより、前回のものを理解しましょう。 (元夏バテ） ---- それで、ご自身に関係のないコメントは削除ですかね？ 確かに、直接関係のない事を書いて居た方が悪いのかもしれません。 そうであれば謝罪します。 今回は、数字の文字列がありますので、 書き出す前にセルの書式を設定してください。 （設定の方法は、日付型でしたが　貴方が削除なさった所に 　書いてあったのですがね。） あとは、先のコードを変更してもらえば目的の事は出来るでしょう。 基本的には「xに入れるデータをどの様に入れるか」と言うだけの事です。 範囲が広がっていますのでその部分の数字は変更が必要ですが。 頑張ってください。 (HANA) ---- ちなみに ＞基本的には「xに入れるデータをどの様に入れるか」と言うだけの事です。 これは「QQ2」に関してです。 QQ2は、xに 　Shee3用のデータを作って、書き出し 　Shee4用のデータを作って、書き出し 　Shee5用のデータを作って、書き出し と言う作業を行っています。 QQ は 　xにShee3用のデータを作って 　yにShee4用のデータを作って 　zにShee5用のデータを作って 　最後に書き出し と言う流れになっていますので、こちらの方が 読みやすいと思います。 (HANA) ---- 元夏バテさん、HANAさん　早速のご指導ありがとうございます。 >それで、ご自身に関係のないコメントは削除ですかね？ >確かに、直接関係のない事を書いて居た方が悪いのかもしれません。 >そうであれば謝罪します。 私は内容がよく解らず、本文が長くなりすぎていましたので削除しました。 たいへん申し訳なく思っております。 今回、QQを参考にもう一度トライしてみます。 ありがとうございます。 (助けて) ---- 校長先生、削除記事の復元ありがとうございました。 （キリキ）（〃⌒o⌒)b ---- いろいろと皆様にご迷惑おかけしてます。申し訳ございません。 今日から再びトライしています。 ご指導のほど、よろしくお願いします。 下記が現在までです。 Sub mac1() Dim dic1 As Object, dic2 As Object Dim i As Long, ii As Long, xr As Long, yr As Long, zr As Long, cc As Long Dim s As String Dim x, y, z, tbl1, tbl2 Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") tbl1 = Sheets("Sheet1").Range("A1").Resize(Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row, 9) tbl2 = Sheets("Sheet2").Range("A1").Resize(Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row, 6) ReDim x(1 To UBound(tbl1, 1), 1 To 8) ReDim y(1 To UBound(tbl1, 1) + UBound(tbl2, 1), 1 To 14) ReDim z(1 To UBound(tbl2, 1) + UBound(tbl1, 1), 1 To 11) For i = 1 To UBound(tbl1, 1) s = tbl1(i, 3) & "♪" & tbl1(i, 7) dic1(s) = dic1(s) + tbl1(i, 6) Next For i = 1 To UBound(tbl2, 1) dic2(tbl2(i, 2) & "♪" & tbl2(i, 4)) = Empty Next For cc = 1 To 8 x(1, cc) = tbl1(1, cc) Next xr = 1 For i = 1 To UBound(tbl1, 1) If Not dic2.exists(tbl1(i, 3) & "♪" & tbl1(i, 7)) Then xr = xr + 1 For cc = 1 To 8 x(xr, cc) = tbl1(i, cc) Next End If Next For i = 1 To UBound(tbl2, 1) s = tbl2(i, 2) & "♪" & tbl2(i, 4) If Not dic1.exists(s) Then yr = yr + 1 For yc = 1 To 6 y(yr, yc) = IIf(yc < 6, tbl2(i, yc), "err") Next Else zr = zr + 1 For ii = 1 To UBound(tbl1, 1) If s = tbl1(ii, 3) & "♪" & tbl1(ii, 7) Then yr = yr + 1 For cc = 1 To 8 y(yr, cc + 6) = IIf(cc <> 8, tbl1(ii, IIf(cc < 8, cc, cc + 1)), IIf(yr = 1, "結果", "ok")) Next For cc = 1 To 3 z(zr, cc) = tbl1(ii, cc) Next For cc = 7 To 9 z(zr, cc - 3) = IIf(cc < 9, tbl1(ii, cc), IIf(zr = 1, "合計", dic1(s))) Next End If Next End If Next Sheets("Sheet3").Cells.ClearContents Sheets("Sheet3").Range("A1").Resize(xr, 8) = x Sheets("Sheet4").Cells.ClearContents Sheets("Sheet4").Range("A1").Resize(yr, 14) = y Sheets("Sheet5").Cells.ClearContents Sheets("Sheet5").Range("A1").Resize(zr, 11) = z Set dic1 = Nothing Set dic2 = Nothing End Sub 実行結果です。 [sheet3] ----------------------------------------- |a1 |a2 |a3key1 |a4 |a5 |a6 |a7key2 |a8 | |a1 |a2 |a3key1 |a4 |a5 |a6 |a7key2 |a8 | |赤 | 2 | 2 | 1 | 10| 10| 201 | 0 | |赤 | 1 | 1 | 1 | 10| 10| 102 | 0 | |赤 | 3 | 3 | 1 | 10| 10| 303 | 0 | ----------------------------------------- [sheet4] -------------------------------------------------------------------------- |b1 |b2key1 |b3 |b4key2 |b5 |err| | | | | | | | | | | | | | | |赤 | 1 | 1 | 1 | 10| 10| 101 |ok | | | | | | | |赤 | 1 | 1 | 1 | 10| 10| 101 |ok | |2 | 2 | 1 | 203 | 10|err| | | | | | | | | | | | | | | |赤 | 2 | 2 | 1 | 10| 10| 202 |ok | -------------------------------------------------------------------------- [sheet5] -------------------------------------------------------------- |赤 | 1 | 1 | 101 | 0 |合計| | | | | | |赤 | 2 | 2 | 202 | 0 | 10| | | | | | -------------------------------------------------------------- 質問 @sheet3で見出しが2行表示される。 Asheet4でsheet1情報の見出しを表示したい。 Bsheet4で見出し行のerr項目が"結果"と表示されない。 Csheet4でsheet1情報の"a8"項目も表示したい。 Dsheet4で結果項目の"ok"を"err"項目と同一箇所に表示したい。 Esheet5で見出し行が表示されない。 VBAが未熟なものですから、なにとぞアドバイスのほど よろしくお願い申し上げます。 (助けて) ---- とりあえず、説明のため　先のQQのコードに まとまり毎に番号を入れました。 文章は今から考えるので、気長にお待ち下さい。 (HANA) ---- こんばんは！下からお邪魔します。 途中は全然見てませんが、ちょっと作ってみましたので良かったら試してみてください。 一応ご提示されたデータだけでしたらその様にはなりました。 あまり検証していませんので後は適当に応用して頂けると幸いです。 ちょっと無駄が多いみたいなので気に入らないけど、、、もう夜も遅いので寝ます。 Sheet1 a1 a2 a3key1 a4 a5 a6 a7key2 a8 赤 1 1 1 10 10 101 0 赤 2 2 1 10 10 201 0 赤 1 1 1 10 10 101 0 赤 1 1 1 10 10 102 0 赤 3 3 1 10 10 303 0 赤 2 2 1 10 10 202 0 Sheet2 b1 b2key1 b3 b4key2 b5 1 1 1 101 20 2 2 1 203 10 3 2 1 202 10 Sheet3 a1 a2 a3key1 a4 a5 a6 a7key2 a8 赤 2 2 1 10 10 201 0 赤 1 1 1 10 10 102 0 赤 3 3 1 10 10 303 0 Sheet4 b1 b2key1 b3 b4key2 b5 結果 a1 a2 a3key1 a4 a5 a6 a7key2 a8 1 1 1 101 20 ok 赤 1 1 1 10 10 101 0 1 1 1 101 20 ok 赤 1 1 1 10 10 101 0 2 2 1 203 10 Err 3 2 1 202 10 ok 赤 1 1 1 10 10 101 0 Sheet5 a1 a2 a3key1 a7key2 a8 合計 b1 b2key1 b3 b4key2 b5 赤 1 1 101 0 20 1 1 1 101 20 赤 2 2 202 0 10 3 2 1 202 10 Option Explicit Sub てすと() Dim MyDicA As Object Dim MyDicB As Object Dim MyA As Variant Dim MyB As Variant Dim v As Variant Dim x() As Variant Dim y() As Variant Dim z() As Variant Dim i As Long Dim j As Long Dim k As Long Dim n As Long Dim r As Long Dim ii As Long Set MyDicA = CreateObject("Scripting.Dictionary") Set MyDicB = CreateObject("Scripting.Dictionary") With Sheets("Sheet1") MyA = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 8).Value End With With Sheets("Sheet2") MyB = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 5).Value End With 'Sheets1のユニークなキーをMyDicAに取得します。 For i = 1 To UBound(MyA, 1) MyDicA(MyA(i, 3) & MyA(i, 7)) = Empty Next 'Sheets2のユニークなキーをMyDicBに取得します。 For i = 1 To UBound(MyB, 1) MyDicB(MyB(i, 2) & MyB(i, 4)) = Application.Index(MyB, i, 0) Next 'sheet1とsheet2を"key1""key2"でマッチングします。 'マッチングしなかったsheet1は､sheet3へコピーします｡ For i = 2 To UBound(MyA, 1) If Not MyDicB.exists(MyA(i, 3) & MyA(i, 7)) Then k = k + 1 ReDim Preserve x(1 To UBound(MyA, 2), 1 To k) For j = 1 To UBound(MyA, 2) x(j, k) = MyA(i, j) Next 'マッチングしたsheet1は､sheet1の内容とsheet2の内容をsheet5へコピーして '"key1""key2"で名寄せしてa6の合計を算出後、合計項目欄に表示します。 Else If MyDicA(MyA(i, 3) & MyA(i, 7)) = Empty Then MyDicA(MyA(i, 3) & MyA(i, 7)) = r + 1 r = MyDicA(MyA(i, 3) & MyA(i, 7)) v = MyDicB(MyA(i, 3) & MyA(i, 7)) ReDim Preserve z(1 To 1 + UBound(MyB, 2) * 2, 1 To r) For j = 1 To 3 z(j, r) = MyA(i, j) Next For j = 4 To 5 z(j, r) = MyA(i, j + 3) Next z(6, r) = z(6, r) + MyA(i, 6) For j = 1 To UBound(MyB, 2) z(UBound(MyB, 2) + 1 + j, r) = v(j) Next Else ReDim Preserve z(1 To 1 + UBound(MyB, 2) * 2, 1 To UBound(z, 2)) r = MyDicA(MyA(i, 3) & MyA(i, 7)) z(6, r) = z(6, r) + MyA(i, 6) End If End If Next 'マッチングしなかったsheet2は､sheet4へコピーして '結果項目欄に"err"と表示します。 For i = 2 To UBound(MyB, 1) If Not MyDicA.exists(MyB(i, 2) & MyB(i, 4)) Then n = n + 1 ReDim Preserve y(1 To UBound(MyA, 2) + UBound(MyB, 2) + 1, 1 To n) y(6, n) = "Err" For j = 1 To UBound(MyB, 2) y(j, n) = MyB(i, j) Next Else 'マッチングしたsheet2は､sheet2の内容とsheet1の内容をsheet4へコピーして '結果項目欄に"ok"と表示します。 v = MyDicB(MyB(i, 2) & MyB(i, 4)) For ii = 2 To UBound(MyA, 1) If MyB(i, 2) & MyB(i, 4) = MyA(ii, 3) & MyA(ii, 7) Then n = n + 1 ReDim Preserve y(1 To UBound(MyA, 2) + UBound(MyB, 2) + 1, 1 To n) y(6, n) = "ok" For j = 1 To UBound(MyB, 2) y(j, n) = v(j) Next For j = UBound(MyB, 2) + 2 To UBound(y, 1) y(j, n) = MyA(i, j - (UBound(MyB, 2) + 1)) Next End If Next End If Next With Sheets("Sheet3") .Cells.ClearContents With .Range("A1") .Resize(1, UBound(MyA, 2)).Value = Application.Index(MyA, 1, 0) .Offset(1).Resize(k, UBound(MyA, 2)).Value = Application.Transpose(x) End With End With With Sheets("Sheet4") .Cells.ClearContents With .Range("A1") .Resize(1, UBound(MyB, 2)).Value = Application.Index(MyB, 1, 0) .Offset(, UBound(MyB, 2)).Value = "結果" .Offset(, UBound(MyB, 2) + 1).Resize(1, UBound(MyA, 2)).Value = Application.Index(MyA, 1, 0) .Offset(1).Resize(n, UBound(y, 1)).Value = Application.Transpose(y) End With End With With Sheets("Sheet5") .Cells.ClearContents With .Range("A1") .Resize(1, UBound(MyA, 2)).Value = Application.Index(MyA, 1, 0) .Offset(, 3).Resize(, 3).Delete .Offset(, 6).Resize(1, UBound(MyB, 2)).Value = Application.Index(MyB, 1, 0) .Offset(, 5).Value = "合計" .Offset(1).Resize(r, UBound(z, 1)).Value = Application.Transpose(z) End With End With Erase MyA, MyB Set MyDicA = Nothing Set MyDicB = Nothing End Sub はやく解決できるといいのね。では、では、またねv(=∩_∩=)v #おっと、さっそく無駄を一つ発見！修正しました。 （SoulMan） ---- まず、QQに関してどの様な構造になっているのか 簡単に書いておきます。 変数 xr は、Sheet3用のデータを入れる変数 x の行番号 　　 yr は、Sheet4用のデータを入れる変数 y の行番号 　　 zr は、Sheet5用のデータを入れる変数 z の行番号 と、それぞれ対応しています。 ★★１★★ 　dictionaryを宣言 　tbl1,tbl2にデータの取り込む 　x,y,zの大きさの設定 ★★２★★ 　dic1の　keyに date ♪ no 　　　　　itemに 該当keyの suryo の合計 　dic2の　keyに date ♪ no 　　　　　itemに Empty 　を書き込む ★★３★★ 　変数xの１行目に、tbl1の１行目を書き込む。 　データは2行目から書き込んでいくので 　「xr = 1」xの行番号を1　に設定 ★★４★★ 　tbl1（Sheet1）の date ♪ no　が 　dic2（Sheet2）のkey（date ♪ no）にあるか確認し 　無い場合、その行のデータを変数xに書き込む。 （この時、１行目=見出し行の実際の値は「date ♪ no」 　これは、dic2に存在するので、変数xに書き込まれない。 　そこで、★★３★★の作業が必要になる。） この行程が済むと、Sheet3用のデータが完成する。 ★★５★★ 　今度は、 　tbl2（Sheet2）の date ♪ no　が 　dic1（Sheet1）のkey（date ♪ no）にあるか確認する。 　無い場合 ★★５−１−１★★ 　変数yに該当データを書き込むが、3列目は「err」とする 　有る場合 ★★５−２★★ 　ここから５−３までを一連として、tbl1の最終行まで繰り返す。 　tbl2（Sheet2）の date ♪ no　と 　tbl1（Sheet1）の date ♪ no　が等しいか確認 　　等しい場合 ★★５−１−２★★ 　　変数y　にデータを書き込むが 　　3列目の場合で、1行目の場合は「err」1行目でない場合は「ok」とする （変数yの見出し行が書き込まれるのは、この部分です。 　tbl2（Sheet2）１行目=見出し行の実際の値は「date ♪ no」これが 　dic1（Sheet1）のkey（date ♪ no）にある場合で　★★５−２★★ 　tbl2（Sheet2）の １行目実際の値「date ♪ no」　と 　tbl1（Sheet1）の １行目実際の値「date ♪ no」　が等しい時　★★５−１−２★★　） ★★５−３★★（ここも　５−２が等しい場合） 　　変数z　にデータを書き込むが 　　3列目の場合で、1行目の場合は「gokei」1行目でない場合は「dic1(s)」とする （dic1(s)とは、★★２★★で合計したkey毎のsuryo の合計 　変数zの見出し行が書き込まれるのは、この部分です。） ★★６★★ それぞれのデータをシートに書き出す ★★７★★ dictionaryを空にする。 ★★以上★★ iiに関しては書きましたが、iに関しては書いてないので 適宜入れて読んでください。 流れとしては、このような流れです。 ＞@sheet3で見出しが2行表示される。 今回は、それぞれの見出し行が異なっている為 ★★４★★の所で見出し行が書き込まれます。 しかし★★３★★も行っているため、見出しが2行表示されます。 ＞Asheet4でsheet1情報の見出しを表示したい。 sheet2の情報を変数yに書き出す際、 「yrが１（１行目）だったら、sheet1の見出し行を一緒に入力 　1行目出なかったら、sheet2の情報のみ 入力」 と言うコードにしてみるのはどうでしょう。 ・・・まぁ、必ず必要なので　どのタイミングででも 入れておけばよいと思いますが・・・・。 ＞Bsheet4で見出し行のerr項目が"結果"と表示されない。 コード内の For yc = 1 To 6 y(yr, yc) = IIf(yc < 6, tbl2(i, yc), "err") Next この部分で、見出しを含むデータを書き出しています。 yc<6でない時で、yrが1の時「結果」それ以外「err」と言う書き方をすれば 変数yの1行目の6列目に「結果」と言う文字が入ります。 ＞Csheet4でsheet1情報の"a8"項目も表示したい。 該当部分は For cc = 1 To 8 y(yr, cc + 6) = IIf(cc <> 8, tbl1(ii, IIf(cc < 8, cc, cc + 1)), IIf(yr = 1, "結果", "ok")) Next ココですよね？ 8+6列目は「IIf(yr = 1, "結果", "ok")」になっているので "a8"項目は入らないのだと思いますが・・・？ ＞Dsheet4で結果項目の"ok"を"err"項目と同一箇所に表示したい。 それ以前に、okの時のsheet2の情報（A:E）は無くて良いのですか？ ＞Esheet5で見出し行が表示されない。 見出し行に関しては、何度か書いているので「やっぱりか」と思われるかもしれませんが 前回と違って、今回は、sheet1とsheet2の見出しが違うため　個別に書き出す必要があります。 ★★３★★に該当するコードを変数z　に関しても追加してください。 とりあえず、QQを今回用に変更したコードです。 不具合があれば第一に、御質問があればそれもまた 書き込んで下さいますよう宜しく御願いします。 なお、書き出すシートが常に新しい物（データ無し・書式設定無し）の場合 　.ClearContents の行は不要で、.NumberFormat の行だけあれば良いでしょう。 書き出すシートがデータが有り、既に書式設定が為されているのなら 　.ClearContents の行は必要で、.NumberFormat の行は不必要かもしれません。 書き出すシートがデータは無いが、既に書式設定が為されているなら 　.ClearContents の行は不要で、.NumberFormat の行も不必要かもしれません。 実状や、将来を見越して　何が必要かはご検討下さい。 　 Sub QQ_1() Dim dic1 As Object, dic2 As Object Dim i As Long, ii As Long, xr As Long, yr As Long, zr As Long, cc As Long Dim s As String Dim x, y, z, tbl1, tbl2 '★★★１★★★★★★★ Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") tbl1 = Sheets("Sheet1").Range("A1").Resize(Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row, 9) tbl2 = Sheets("Sheet2").Range("A1").Resize(Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row, 6) ReDim x(1 To UBound(tbl1, 1), 1 To 8) ReDim y(1 To UBound(tbl1, 1) + UBound(tbl2, 1), 1 To 14) ReDim z(1 To UBound(tbl2, 1), 1 To 11) '★★★２★★★★★★★ For i = 1 To UBound(tbl1, 1) s = tbl1(i, 3) & "♪" & tbl1(i, 7) dic1(s) = dic1(s) + tbl1(i, 6) Next For i = 1 To UBound(tbl2, 1) dic2(tbl2(i, 2) & "♪" & tbl2(i, 4)) = Empty Next '★★★４★★★★★★★ For i = 1 To UBound(tbl1, 1) If Not dic2.exists(tbl1(i, 3) & "♪" & tbl1(i, 7)) Then xr = xr + 1 For cc = 1 To 8 x(xr, cc) = tbl1(i, cc) Next End If Next '★★zに関して３相当★★ For cc = 1 To 6 z(1, cc) = IIf(cc < 4, tbl1(1, cc), IIf(cc < 6, tbl1(1, cc + 3), "合計")) Next For cc = 7 To 11 z(1, cc) = tbl2(1, cc - 6) Next zr = 1 '★★★５★★★★★★★ For i = 1 To UBound(tbl2, 1) s = tbl2(i, 2) & "♪" & tbl2(i, 4) If Not dic1.exists(s) Then '★★★５−１−１★★★★★ yr = yr + 1 For yc = 1 To 6 '●ここを修正してみました ' y(yr, yc) = IIf(yc < 6, tbl2(i, yc), "結果") y(yr, yc) = IIf(yc < 6, tbl2(i, yc), IIF(yr = 1,"結果","err")) Next '★★yのsheet1の項目に関して３相当★★ If yr = 1 Then For yc = 7 To 14 y(yr, yc) = tbl1(1, yc - 6) Next End If Else '★★★５−２★★★★★ zr = zr + 1 For ii = 1 To UBound(tbl1, 1) If s = tbl1(ii, 3) & "♪" & tbl1(ii, 7) Then '★★★５−１−２★★★ yr = yr + 1 For cc = 1 To 6 y(yr, cc) = IIf(cc < 6, tbl2(i, cc), "ok") Next For cc = 7 To 14 y(yr, cc) = tbl1(ii, cc - 6) Next '★★★５−３★★★★★ For cc = 1 To 6 z(zr, cc) = IIf(cc < 4, tbl1(ii, cc), IIf(cc < 6, tbl1(ii, cc + 3), dic1(s))) Next For cc = 7 To 11 z(zr, cc) = tbl2(i, cc - 6) Next End If Next End If Next '★★★６★★★★★★★ With Sheets("Sheet3") .Cells.ClearContents .Range("B:C,G:G").NumberFormat = "@" .Range("A1").Resize(xr, 8) = x End With With Sheets("Sheet4") .Cells.ClearContents .Range("B:B,D:D,H:I,M:M").NumberFormat = "@" .Range("A1").Resize(yr, 14) = y End With With Sheets("Sheet5") .Cells.ClearContents .Range("B:D, H:H, J:J").NumberFormat = "@" .Range("A1").Resize(zr, 11) = z End With '★★★７★★★★★★★ Set dic1 = Nothing Set dic2 = Nothing End Sub (HANA) ---- SoulManさん、HANAさん 補足説明まで頂ましてありがとうございます。 もう一度、勉強しなおします。 取り急ぎ、お礼申し上げます。 (助けて) ---- 今回もいろいろと勉強になりました。ありがとうございます。 HANAさんの今回のコード文をちょっと修正させていただきました。 ★５−１−１★の部分です。 1行目が"結果"ではなく"err"と表示されたためIIf文を入れました。 書き出しの書式設定は★６★の部分で宣言するんですね。 また、★３★と★４★の関係も解りました。 ひとつ質問です。 ★１★の ReDim y(1 To UBound(tbl1, 1) + UBound(tbl2, 1), 1 To 14) ReDim z(1 To UBound(tbl2, 1), 1 To 11) で、yではtbl1とtbl2を宣言していますが、 zではtbl2だけなのはなぜでしょうか？ SoulManさんのコード文も、とっても解りやすいです。 (助けて) ---- ＞1行目が"結果"ではなく"err"と表示されたためIIf文を入れました。 そうですね、ごめんなさい。 その様に変更してください。 ＞書き出しの書式設定は★６★の部分で宣言するんですね。 これは、書き出す前で有れば何処で処理しても同じです。 「書き出す」と言う作業が、「各シート」に関する処理なので 「各シートの書式を設定する」と言う処理も一緒に 行った方が分かりやすいかと思い、其処へ入れてみました。 私のコードは、見出しが入らない変数に関しては、 データを入れる前に見出し行を入れる処理を行っていますが この行を見て何かを行うわけではないので、 「あの場所に、その処理が必要である」と言う訳では有りません。 seiyaさんのなさって居られるように、書き出す時につけても問題ありません。 ＞Sheets("sheet5").Range("a1").Resize(,3).Value = [{"date","no","gokei"}] ＞yではtbl1とtbl2を宣言していますが、 ＞zではtbl2だけなのはなぜでしょうか？ ここは、変数の行数を何行使いたいか意思表示をする所です。 一番良いのは、実際に使用する行数を設定する事かもしれませんが 実際に使う行より多く指定した所で、メモリを喰うくらいの事です。 （少ないと、動いてくれないので、問題外です。） 「可能性として最大の行数」を考えると、 yに関しては、sheet1に重複がなく、sheet2とも重複がない場合 　　双方の行を足した数分だけ必要になるので、各行数を足した数を zに関しては、sheet2の全てがsheet1に有った場合　で　これは 　　sheet2の行数を超えることがないので、tbl2だけになっています。 （見出し行があるので、実際はもう少し少ないのですが） ちなみに、UBound(tbl1, 1)は、「tbl1の行数」と言う 数値 です。 QQは、最初にも書いているように ＞（結局一つずつ見てるんですよね。） 該当部分は★５−２★の部分です。 例えば、sheet1に1000件データがあり sheet2に100件データがあり sheet1とsheet2の100件全てが重複した場合★５−２★の見比べは 1000*100回行われることになります。 これがどうも無駄っぽいので、QQ2を作りました。 QQ2の変数yは、以下の様になり、それぞれの数字は次の意味を持ちます。 変数y [1] [2] [3] [4] [5] [1] date no [2] 8月1日 7 [3] 3 4 4 5 6 8月2日 4 [4] 8月3日 5 [5] 8月4日 6 date suryo tbl1の ←同じ ←同じ 重複数 合計 行数 sheet2の各行に対応する、sheet1の情報を記録しています。 sheet2の3行目のデータは、 　y(3,1) 「3」件重複があり y(3,2) そのsuryoの合計は「4」 重複した3件はsheet1（tbl1）の y(3,3) 「4」行目、y(3,4)「5」行目、y(3,5)「6」行目に有る。 その他の行は、sheet1に重複無し。 この情報を元に、１行ずつデータを見比べることなく 各シートへ書き出すデータを変数xに作成しています。 データの件数によっては、こちらの方がはやいと思います。 もちろん、現在のものでも早さに問題がなければ良いのですが。 一応、こちらを先に作っていたので載せておきます。 With Sheets("Sheet6") .Cells.ClearContents .Range("A1").Resize(UBound(tbl2, 1), yc + 2) = y End With こんなのを適当な場所に入れておくと、yの値がSheet6に書き出せますので ご参考に。 　 Sub QQ2_1() Dim dic1 As Object, dic2 As Object Dim i As Long, ii As Long Dim xr As Long, yr As Long, tr As Long, rr As Long Dim yc As Long, cc As Long Dim s As String Dim m, x, y, tbl1, tbl2 Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") tbl1 = Sheets("Sheet1").Range("A1").Resize(Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row, 9) tbl2 = Sheets("Sheet2").Range("A1").Resize(Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row, 6) '★ tbl1の重複しないデータを作成 '★ また、そのキーが何件有るかをitemに書き込む For i = 2 To UBound(tbl1, 1) s = tbl1(i, 3) & "♪" & tbl1(i, 7) If Not dic1.exists(s) Then dic1(s) = 1 Else dic1(s) = dic1(s) + 1 End If Next '★ itemの最大の値を求めることで '★ 変数y の列が何列必要か求める For Each m In dic1.items yc = IIf(yc < m, m, yc) Next '★ tbl2の重複しないデータを作成 '★ また、そのキーが何行目に有るかをitemに書き込む For i = 2 To UBound(tbl2, 1) On Error Resume Next dic2.Add tbl2(i, 2) & "♪" & tbl2(i, 4), i Next '★ sheet3用のデータと、sheet2に対応するsheet1の情報を記録（y） ReDim x(1 To UBound(tbl1, 1), 1 To 8) ReDim y(1 To UBound(tbl2, 1), 1 To yc + 2) 　 For cc = 1 To 8 x(1, cc) = tbl1(1, cc) Next xr = 1 For i = 2 To UBound(tbl1, 1) s = tbl1(i, 3) & "♪" & tbl1(i, 7) If dic2.exists(s) Then ii = dic2(s) y(ii, 1) = y(ii, 1) + 1 y(ii, 2) = y(ii, 2) + tbl1(i, 6) y(ii, y(ii, 1) + 2) = i rr = IIf(y(ii, 1) > 1, rr + 1, rr) Else xr = xr + 1 For cc = 1 To 8 x(xr, cc) = tbl1(i, cc) Next End If Next '★ 書き出し With Sheets("Sheet3") .Cells.ClearContents .Range("B:C,G:G").NumberFormat = "@" .Range("A1").Resize(xr, 8) = x End With '★ 変数yの値を見ながら　sheet4用のデータを作成 ReDim x(1 To rr + UBound(tbl2, 1), 1 To 14) 　 For cc = 1 To 6 x(1, cc) = IIf(cc = 6, "結果", tbl2(1, cc)) Next For cc = 7 To 14 x(1, cc) = tbl1(1, cc - 6) Next xr = 1 rr = 0 For i = 2 To UBound(y, 1) If y(i, 1) = Empty Then xr = xr + 1 For cc = 1 To 6 x(xr, cc) = IIf(cc = 6, "err", tbl2(i, cc)) Next Else rr = rr + 1 For ii = 1 To y(i, 1) tr = y(i, ii + 2) xr = xr + 1 For cc = 1 To 6 x(xr, cc) = IIf(cc = 6, "ok", tbl2(i, cc)) Next For cc = 7 To 14 x(xr, cc) = tbl1(tr, cc - 6) Next Next End If Next '★ 書き出し With Sheets("Sheet4") .Cells.ClearContents .Range("B:B,D:D,H:I,M:M").NumberFormat = "@" .Range("A1").Resize(xr, 14) = x End With '★ 変数yの値を見ながら　sheet5用のデータを作成 ReDim x(1 To rr + 1, 1 To 11) 　 For cc = 1 To 6 x(1, cc) = IIf(cc < 4, tbl1(1, cc), IIf(cc < 6, tbl1(1, cc + 3), "合計")) Next For cc = 7 To 11 x(1, cc) = tbl2(1, cc - 6) Next xr = 1 For i = 2 To UBound(y, 1) If y(i, 1) > 0 Then tr = y(i, 3) xr = xr + 1 For cc = 1 To 6 x(xr, cc) = IIf(cc < 4, tbl1(tr, cc), IIf(cc < 6, tbl1(tr, cc + 3), y(i, 2))) Next For cc = 7 To 11 x(xr, cc) = tbl2(i, cc - 6) Next End If Next '★ 書き出し With Sheets("Sheet5") .Cells.ClearContents .Range("B:D, H:H, J:J").NumberFormat = "@" .Range("A1").Resize(xr, 11) = x End With Set dic1 = Nothing Set dic2 = Nothing End Sub (HANA) ---- HANAさん、いつもありがとうございます。 すごく勉強になります。 早く理解して次のステップに進みたいと思います。 (助けて)