[[20150409161816]]　『最新のデータだけ追記する』（ニワ）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『最新のデータだけ追記する』（ニワ）

 フォルダに，Aというファイルがあります。
 Aファイルの３列目，５行目以降，つまり，C5セルより下にデータが入っています。
 たとえば，C5〜C9セルに，あ，い，う，え，お，とデータが入っています。

 このフォルダに，任意の名称のファイルを保存します。
 その任意のファイルの，C5〜C12セルに，あ，い，う，え，お，か，き，く，とデータが入っています。

 ここで，Aファイルと任意のファイルを比べると，か，き，く，の部分が追加されたデータになります。

 ここで，任意のファイルの，か，き，く，のデータがある行を，Aファイルの　お　のデータがある行の
 次の行に挿入するマクロを，Aファイル上にに作りたいと思います。
 つまり，AファイルのC10〜C12セルに，か，き，く　のデータが追加されて，
 AファイルのC5〜C12セルが，あ，い，う，え，お，か，き，く　と表示されるようにしたいのです。

 ご教示願います。

＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞

---

 Sub test()
    Dim vFile As Variant
    Dim i As Long
    Dim j As Long
    Dim iR As Long

    iR = Cells(Rows.Count, "C").End(xlUp).Row

    vFile = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
    If vFile <> False Then
        Application.ScreenUpdating = False
        With Workbooks.Open(vFile, False, True)
            With .Sheets(1)
                For i = 5 To .Cells(.Rows.Count, "C").End(xlUp).Row
                    For j = 5 To iR
                        If .Cells(i, "C").Value = Cells(j, "C").Value Then
                            Exit For
                        End If
                    Next j
                    If j = iR + 1 Then
                        iR = iR + 1
                        .Rows(i).Copy Rows(iR)
                    End If
                Next i
            End With
            .Close
        End With
        Application.ScreenUpdating = True
    End If
 End Sub
（???） 2015/04/09(木) 16:48

---

 以下のコード、ファイルそれぞれの構成に関して誤解がある可能性ありますがとりあえず。
 ブックAがマクロブック。マクロ内で表示するダイアログで【任意のブック名】を指定。
 ブック名指定時は拡張子不要。（xxxxxx.xlsx ではなく xxxxx のみ。 .xlsx をつけてもいいけど無視。最終的に拡張子は .xlsx固定）

 ブックAの標準モジュールに。

 Sub Test()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicF As Object
    Dim dicT As Object
    Dim c As Range
    Dim z As Long

    Application.ScreenUpdating = False

    fName = Application.InputBox("抽出ブックの名前を入れてください", Type:=2)
    If fName = False Then Exit Sub 'キャンセルボタン
    fName = Split(fName, ".")
    fName = fName(0) & ".xlsx"
    fPath = ThisWorkbook.Path & "\"

    If Dir(fPath & fName) = "" Then
        MsgBox fName & "　がありません"
        Exit Sub
    End If

    Set dicF = CreateObject("Scripting.Dictionary")
    Set dicT = CreateObject("Scripting.Dictionary")
    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = fSh.Range("A1", fSh.UsedRange).Columns.Count

    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        dicT(c.Value) = True
    Next

    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        If Not dicT.exists(c.Value) Then dicF(dicF.Count) = c.EntireRow.Range("A1").Resize(, z).Value
    Next

    If dicF.Count > 0 Then
        tSh.Range("C" & Rows.Count).End(xlUp).Offset(1, -2).Resize(dicF.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicF.items))
    End If

    fSh.Parent.Close False

 End Sub

（β） 2015/04/09(木) 16:58

---

 どうもありがとうございます。

 βさんのマクロ、うまく動きました。
 それで，"抽出ブックの名前を入れてください"というメッセージは出ないようにしたいのですが。

 要するに，

 　　　Aという名前以外のファイル

 をフォルダに保存したとき，
 そのファイル内のデータを検索して，追加されたデータをAファイル内で行挿入するという風にしたいのですが。

 いかがでしょうか。

 ???さんのマクロはうまく動きませんでした。すみません。

（ニワ） 2015/04/09(木) 22:00

---

 いったん、否定的なコメントをアップしましたが、要望は、自動実行ではなく
 このマクロを走らせて、マクロブックがあるフォルダの中の、何かしらのエクセルブック（○○○.xlsx)があれば、
 それを抽出ということであれば以下。

 ただし、それが目的のブックかどうかの保証はできないのでは？

 Sub Test2()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicF As Object
    Dim dicT As Object
    Dim c As Range
    Dim z As Long

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicF = CreateObject("Scripting.Dictionary")
    Set dicT = CreateObject("Scripting.Dictionary")
    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = fSh.Range("A1", fSh.UsedRange).Columns.Count

    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        dicT(c.Value) = True
    Next

    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        If Not dicT.exists(c.Value) Then dicF(dicF.Count) = c.EntireRow.Range("A1").Resize(, z).Value
    Next

    If dicF.Count > 0 Then
        tSh.Range("C" & Rows.Count).End(xlUp).Offset(1, -2).Resize(dicF.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicF.items))
    End If

    fSh.Parent.Close False

 End Sub

（β） 2015/04/09(木) 22:14

---

私のマクロは、Aファイルの追記するシートのシートモジュールに貼って動かしてください。
標準モジュールではないです。
（???） 2015/04/10(金) 12:27

---

 ありがとうございます。うまくいきました。
 もう少し，お教え願います。

 まず，Aファイルのデータは，　あ　い　う　え　お　のままとします。
 次に，任意ファイルのデータを，上記の　あ　い　う　え　お　か　き　く　から，
 い　え　のデータを除いて，　あ　う　お　か　き　く　とします。

 上記のマクロを実行すると，か　き　く　が追加分として，Aファイルの　お　の次に挿入され，
 Aファイルのデータは，あ　い　う　え　お　か　き　く　となります。

 ここで，さらに，Aファイルと任意のファイルを比べると，Aファイルにある　い　え　のデータが，任意ファイルにはありません。
 それで，Aファイル上で，この任意のファイルにはない　い　え　のデータがある行を，あ　の行の前に挿入して，

 ⑴　Aファイルのデータを　い　え　あ　う　お　か　き　く　と並べたいのです。
 ⑵　さらに，先頭に挿入した　い　え　のデータがある行について，A列からE列までの色を黄色に変えたいのです。

 すみませんが，よろしくご教示お願いします。

（ニワ） 2015/04/11(土) 21:50

---

 以下でお試しください。

 Sub Test3()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicF As Object
    Dim dicT As Object
    Dim dicA As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicF = CreateObject("Scripting.Dictionary")
    Set dicT = CreateObject("Scripting.Dictionary")
    Set dicA = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = fSh.Range("A1", fSh.UsedRange).Columns.Count

    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        dicT(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
    Next

    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicA(c.Value) = True
        If Not dicT.exists(c.Value) Then dicF(dicF.Count) = c.EntireRow.Range("A1").Resize(, z).Value
    Next

    If dicF.Count > 0 Then
        tSh.Range("C" & Rows.Count).End(xlUp).Offset(1, -2).Resize(dicF.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicF.items))
    End If

    For Each k In dicT
        If dicA.exists(k) Then dicT.Remove k
    Next

    If dicT.Count > 0 Then
        fSh.Rows(5).Resize(dicT.Count).Insert shift:=xlDown
        fSh.Range("A5").Resize(dicT.Count, z).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicT.items))
        fSh.Range("A5:E5").Resize(dicT.Count).Interior.Color = vbYellow
    End If

    fSh.Parent.Close True

 End Sub

（β） 2015/04/12(日) 06:45

---

 どうもありがとうございます。

 上記のコードを試してみましたが，Aファイルのデータ　あ　い　う　え　お　に，追加分　か　き　く
 が挿入されて，「Aファイル上」のデータが　あ　い　う　え　お　か　き　く　となるところまではうまく動きます。

 そこから，「Aファイル上で」，い　え　のデータ（任意のファイルのデータ　あ　う　お　か　き　く　と比べて，はじかれるもの）
 を前に出して，色を付けることをしたいのです。

 ご教示いただいたコードでは，「任意のファイル上」で，元のデータ　あ　う　お　か　き　く　の前に
 い　え　のデータが挿入されて，色が付くようになっています。

 大変ややこしくて申し訳ありませんが，お教え願います。

（ニワ） 2015/04/12(日) 09:10

---

 要件をすっかり読み違えていましたね。
 以下で試してみてください。

 Sub Test4()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicA As Object
    Dim dicB As Object
    Dim dicC As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Range

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = fSh.Range("A1", fSh.UsedRange).Columns.Count

    '任意のブックのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicC(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
    Next
    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにもある
        Else
            dicA(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにはない
        End If
    Next
    '任意のブックのデータでマクロブックにもあるものを削除
    For Each k In dicC
        If dicA.exists(k) Or dicB.exists(k) Then dicC.Remove k
    Next

    Set pos = tSh.Range("A5")   '転記開始位置

    If dicA.Count > 0 Then
        pos.Resize(dicA.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        pos.Resize(dicA.Count, 5).Interior.Color = vbYellow
        Set pos = pos.Offset(dicA.Count)
    End If

    If dicB.Count > 0 Then
        pos.Resize(dicB.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicB.items))
        Set pos = pos.Offset(dicB.Count)
    End If

    If dicC.Count > 0 Then
        pos.Resize(dicC.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicC.items))
    End If

    fSh.Parent.Close False

 End Sub

（β） 2015/04/12(日) 13:45

---

 ありがとうございます。
 うまくできました。
 すごくいいものを作っていただきました。
（ニワ） 2015/04/12(日) 15:20

---

 すみませんが，ちょっと不具合が出ましたので，お教え願います。

 AファイルのC5〜C9セルに，あ，い，う，え，お，とデータが入っています。
 そして，B5〜B9セルに，ア，イ，ウ，エ，オ，とデータが，
 D5〜D9セルに，１，２，３，４，５，とデータが入っています。

 また，任意ファイルのC5〜C10セルに，あ，う，お，か，き，く，とデータが，
 B5〜B10セルに，ア，ウ，オ，カ，キ，ク　とデータが入っています。
 D列のセルにはデータが入っていません。

 この条件で，上記Test4のマクロを実行すると，「Aファイル上で」，い　え　のデータ
 （任意のファイルのデータ　あ　う　お　か　き　く　と比べて，はじかれるもの）は前に出て，黄色になります。
 さらに，い　え　のデータの左横にある　イ　エ　のデータも前に出て，黄色になります。
 しかし，い　え　のデータの右横にある　２，４　のデータは前に出ません。
 D5〜D9セルのデータは，１，２，３，４，５，と並んだままです。

 これを，い，え　のデータが含まれる行ごと前に出るようにしたいのですが，いかがでしょうか
 　
（ニワ） 2015/04/18(土) 12:48

---

 ↑で説明のあったデータにして Test4を実行した結果、こちらでは

     |[A]|[B]|[C]|[D]|[E]
 [1] |   |   |   |   |   
 [2] |   |   |   |   |   
 [3] |   |   |   |   |   
 [4] |   |   |   |   |   
 [5] |   |イ |い |  2|   
 [6] |   |エ |え |  4|   
 [7] |   |ア |あ |  1|   
 [8] |   |ウ |う |  3|   
 [9] |   |オ |お |  5|   
 [10]|   |   |か |   |   
 [11]|   |   |き |   |   
 [12]|   |   |く |   |   

 5行目、６行目のA〜D列が黄色くなっています。

 そちらでは違う結果ですか？不思議ですねぇ？

 (貼り付けたイメージは、学校で過去にmomoさんが紹介された投稿用イメージ作成ユーティリティを使い、実行結果を、そのまま加工したものです）

（β） 2015/04/18(土) 13:05

---

 あぁ、わかりました。
 任意ブックのシートのD列に値がないんですね。
 ちょっと考えてみます。

 （コピー領域をできるだけ絞りたかったんですが、最悪、行全体にします）

（β） 2015/04/18(土) 16:22

---

 コピー元、コピー先の列数の大きいほうを採用しました。

 z = fSh.Range("A1", fSh.UsedRange).Columns.Count

 これを

 z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, tSh.Range("A1", tSh.UsedRange).Columns.Count)

 に変更してください。

（β） 2015/04/18(土) 16:30

---

 うまくできました。
 列の数の違いに対応できました。

 すみませんが，もう１つお教え願います。
 今までのことを整理すると，
 Aファイル上で
 か，き，く　のデータを含む行が新しく挿入される
 い，え　のデータを含む行がはじかれて，上部に移動して黄色になります。

 それで，残りの　あ　う　お　のデータを含む行についてです。
 任意ファイル上で，C5〜C7セルに，あ，う，お，とデータが，
 そして，E5〜E7セルに，（ア），（ウ），（オ），とデータが入っているとします。

 この（ア），（ウ），（オ）のデータを，Aファイル上の対応する　あ　う　お　のデータの右横のE7〜E9セルに
 貼り付ける　ということを，上記Test4のマクロに加えたいのですが，いかがでしょうか。

 要するに，任意ファイルのデータの中で，Aファイルと比べて，新規追加やはじかれるデータにならないデータについて
 対応するE列のデータを，Aファイル上の対応するE列に貼り付ける
 としたいのですが，いかがでしょうか。

（ニワ） 2015/04/19(日) 09:11

---

 こういうことですか？
 で、仮に、このコードが要件の誤解なくＯＫだったとします。
 でも、今後、あれも、こうしたい、これも、ああしたい　と、そういったことがあった都度、質問をアップされますか？
 もちろん、目に留まれば、その時もお手伝いはしますが、やはり、コードの各行で、何をしているのか、
 それを、しっかりと理解しておいてほしいですね。そうすれば、少しは自助努力で、今後の追加改定に対応できるかもしれませんので。

 Sub Test5()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicA As Object
    Dim dicB As Object
    Dim dicC As Object
    Dim dicD As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Range

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")
    Set dicD = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, tSh.Range("A1", tSh.UsedRange).Columns.Count)

    '任意のブックのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicC(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
        dicD(c.Value) = c.EntireRow.Range("E1").Value
    Next
    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにもある
        Else
            dicA(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにはない
        End If
    Next
    '任意のブックのデータでマクロブックにもあるものをDicCから削除
    For Each k In dicC
        If dicA.exists(k) Or dicB.exists(k) Then
            dicC.Remove k
        End If
    Next

    Set pos = tSh.Range("A5")   '転記開始位置

    If dicA.Count > 0 Then
        pos.Resize(dicA.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        pos.Resize(dicA.Count, 5).Interior.Color = vbYellow
        Set pos = pos.Offset(dicA.Count)
    End If

    If dicB.Count > 0 Then
        pos.Resize(dicB.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicB.items))
        For Each c In pos.Resize(dicB.Count)
            c.EntireRow.Range("E1").Value = dicD(c.EntireRow.Range("C1").Value)
        Next
        Set pos = pos.Offset(dicB.Count)
    End If

    If dicC.Count > 0 Then
        pos.Resize(dicC.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicC.items))
    End If

    fSh.Parent.Close False

 End Sub

（β） 2015/04/19(日) 13:34

---

 どうもありがとうございます。
 もう１つ不具合がありまして。
 いろいろ研究しましたが，よく分からないので，申し訳ありませんが，お教え願います。

 AファイルのC5〜C9セルの，あ，い，う，え，お，のデータに　赤，青，黄，緑，紫　と文字色を付けます。
 あ→赤，い→青，う→黄，え→緑，お→紫　となります。

 それで，マクロを実行すると，い，え　のデータが上にはじかれて，データが　い，え，あ，う，お　と並びます。
 しかし，文字色の並びは，赤青黄緑紫のままで，

 い→赤，え→青，あ→黄，う→緑，お→紫

 と，文字色が当初の色とは変わってしまいます。
 文字色だけでなく，セルに色を付けても同じですし
 隣のB列やD列のデータに色を付けても同じ現象となります。

 これを文字色やセル色も，データの移動に合わせて移動するようにしたいのですが。

 すみませんが，お教え願います。

（ニワ） 2015/04/26(日) 09:37

---

 現在の構えは、セルの値のみを転記していますので文字色や背景色は、上に押し上げられるもの（実際に押し上げられているのではなく、上に転記されているだけ）
 の背景色を黄色にする以外はもともとのAファイルの各セルの背景色や文字色はそのままですので、そこに値が転記されてもそれらは、もとのままですね。

 現在の構えを踏襲するなら相当な小細工が必要。
 さもなければ、処理方式を完全に別物にして書き直す必要があります。

 いずれも、すぐにどうぞというシロモノではなさそうな予感。時間ください。

 ところで、上に【押し上げられたもの】は、背景色は、元がなんであれ黄色になりますよね。
 それはいいんですね？で、文字色は元のものを踏襲？

 ところで、β的にいうと、これは【不具合】とはいわれたくないですねぇ。
 不具合というのは、仕様どおりに結果がでないケース、いわゆる【プログラムバグ】つまり【プログラムの間違い】

 今回の件はあくまで要件の変更だと思っていますよ。

 追加で。

 もし、任意ブック側のデータにも背景色や文字色があって、それをAファイルに反映させるときはそれも継承ということなら
 早めにいってくださいね。

（β） 2015/04/26(日) 14:00

---

 ありがとうございます。
 次から次と、注文ばかり、また、大変失礼な書き込み申し訳ありません。
 おっしゃるとおり、押し上げられたものは、背景色が黄色になり、文字色は元のままで構いません。
 あと、任意ブックの色は継承しません。

 よろしくお願いいたします。

（ニワ） 2015/04/26(日) 15:06

---

 抜本的にコードを書き直そうとも思ったのですが気力が萎えて、アップ済みの Test5 に小細工をほどこしました。

 Sub Test6()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicA As Object
    Dim dicB As Object
    Dim dicC As Object
    Dim dicD As Object
    Dim dicApat As Object
    Dim dicBpat As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Range
    Dim w As Variant
    Dim tmp As Range
    Dim x As Long
    Dim myColor As Long

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")
    Set dicD = CreateObject("Scripting.Dictionary")
    Set dicApat = CreateObject("Scripting.Dictionary")
    Set dicBpat = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, tSh.Range("A1", tSh.UsedRange).Columns.Count)
    '任意のブックのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicC(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
        dicD(c.Value) = c.EntireRow.Range("E1").Value
    Next
    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        w = GetColor(c, z)
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにもある
            dicBpat(c.Value) = w
        Else
            dicA(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにはない
            dicApat(c.Value) = w
        End If
    Next
    '任意のブックのデータでマクロブックにもあるものをDicCから削除
    For Each k In dicC
        If dicA.exists(k) Or dicB.exists(k) Then
            dicC.Remove k
        End If
    Next

    With tSh.Range("A1", tSh.UsedRange)
        With .Offset(4).Resize(, z)
            .Interior.ColorIndex = xlNone
            .Font.ColorIndex = xlAutomatic
        End With
    End With

    Set pos = tSh.Range("A5")   '転記開始位置

    If dicA.Count > 0 Then
        pos.Resize(dicA.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        pos.Resize(dicA.Count, z).Interior.Color = vbYellow
        '文字色復元
        Set tmp = pos
        For Each w In dicApat.items
            For x = 1 To z
                tmp.Offset(, x - 1).Font.Color = w(x + z)
            Next
            Set tmp = tmp.Offset(1)
        Next
        Set pos = pos.Offset(dicA.Count)
    End If

    If dicB.Count > 0 Then
        pos.Resize(dicB.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicB.items))
        For Each c In pos.Resize(dicB.Count)
            c.EntireRow.Range("E1").Value = dicD(c.EntireRow.Range("C1").Value)
        Next
        '文字色と背景色復元
        Set tmp = pos
        For Each w In dicBpat.items
            For x = 1 To z
                myColor = w(x)
                If myColor = vbWhite Then
                    tmp.Offset(, x - 1).Interior.ColorIndex = xlNone
                Else
                    tmp.Offset(, x - 1).Interior.Color = w(x)
                End If
                tmp.Offset(, x - 1).Font.Color = w(x + z)
            Next
            Set tmp = tmp.Offset(1)
        Next

        Set pos = pos.Offset(dicB.Count)
    End If

    If dicC.Count > 0 Then
        pos.Resize(dicC.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicC.items))
    End If

    fSh.Parent.Close False

 End Sub

 Private Function GetColor(c As Range, z As Long)
    Dim w As Variant
    Dim x As Long
    Dim col As Long

    ReDim w(1 To z * 2)
    With c.EntireRow
        For x = 1 To z
            w(x) = .Cells(1, x).Interior.Color
            w(x + z) = .Cells(1, x).Font.Color
        Next
    End With
    GetColor = w
 End Function

（β） 2015/04/26(日) 22:07

---

 うまくできました。
 大変お世話になりました。
 ありがとうございました。
（ニワ） 2015/04/27(月) 19:16

---

 すみませんが，また，【要件の変更】がありましたので，ご教示願います。
 何度も申し訳ありません。
 お助け願います。

 AファイルのC5〜C9セルのデータを，ああ，いい，うう，ええ，おお，とします。
 そして，各データの文字色に異なる色をつけます。
 たとえば

 ああ→赤紫，いい→青赤，うう→黄青，ええ→緑黄，おお→紫緑

 とします。
 それで上記マクロを実行すると，全部の文字色が黒になってしまいます。
 隣のB列やD列のデータでも，複数の文字に異なる色を付けると，全部の文字が黒くなります。

 これを元の文字色が維持されるようにしたいのです。
 よろしくお願いします。

（ニワ） 2015/05/07(木) 22:37

---

 少し疲れました。
 こういう要件があるなら、なぜ最初からいわないんですか？
 なんか、答えを出すたびに、それなら、これはできるか、じゃぁ、こんなことはできるか、どうだ、まいったか　と、
 遊ばれているような気がしますねぇ・・・・

 まぁ、やってみますけどね。時間ください。

（β） 2015/05/07(木) 23:14

---

 βさん，ありがとうございます。
 毎日，活用させていただいており，大変感謝しております。

 毎日使う中で，「こないだ直していただいたはずなのに，なんでこんな動きになるの？」
 という現象にぶち当たりまして，原因を解析して，それを簡単な事例に直してアップしている次第です。

 こんな私に対応していただいて本当にありがとうございます。
 よろしくお願いします。
（ニワ） 2015/05/08(金) 05:24

---

 簡単なテストはしましたが、さて、どうなりますか。

 Sub Test7()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicA As Object
    Dim dicB As Object
    Dim dicC As Object
    Dim dicD As Object
    Dim dicApat As Object
    Dim dicBpat As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Range
    Dim w As Variant
    Dim tmp As Range
    Dim x As Long
    Dim myColor As Long
    Dim i As Long

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")
    Set dicD = CreateObject("Scripting.Dictionary")
    Set dicApat = CreateObject("Scripting.Dictionary")
    Set dicBpat = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, tSh.Range("A1", tSh.UsedRange).Columns.Count)
    '任意のブックのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicC(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
        dicD(c.Value) = c.EntireRow.Range("E1").Value
    Next
    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        w = GetColor(c, z)
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにもある
            dicBpat(c.Value) = w
        Else
            dicA(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value   '任意ブックにはない
            dicApat(c.Value) = w
        End If
    Next
    '任意のブックのデータでマクロブックにもあるものをDicCから削除
    For Each k In dicC
        If dicA.exists(k) Or dicB.exists(k) Then
            dicC.Remove k
        End If
    Next

    With tSh.Range("A1", tSh.UsedRange)
        With .Offset(4).Resize(, z)
            .Interior.ColorIndex = xlNone
            .Font.ColorIndex = xlAutomatic
        End With
    End With

    Set pos = tSh.Range("A5")   '転記開始位置

    If dicA.Count > 0 Then
        pos.Resize(dicA.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        pos.Resize(dicA.Count, z).Interior.Color = vbYellow
        '文字色復元
        Set tmp = pos
        For Each w In dicApat.items
            For x = 1 To z
                If tmp.Offset(, x - 1).Value <> "" Then
                    For i = 1 To UBound(w(x + z))
                        tmp.Offset(, x - 1).Characters(Start:=i, Length:=1).Font.Color = w(x + z)(i)
                    Next
                End If
            Next
            Set tmp = tmp.Offset(1)
        Next
        Set pos = pos.Offset(dicA.Count)
    End If

    If dicB.Count > 0 Then
        pos.Resize(dicB.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicB.items))
        For Each c In pos.Resize(dicB.Count)
            c.EntireRow.Range("E1").Value = dicD(c.EntireRow.Range("C1").Value)
        Next
        '文字色と背景色復元
        Set tmp = pos
        For Each w In dicBpat.items
            For x = 1 To z
                myColor = w(x)
                If myColor = vbWhite Then
                    tmp.Offset(, x - 1).Interior.ColorIndex = xlNone
                Else
                    tmp.Offset(, x - 1).Interior.Color = w(x)
                End If
                If tmp.Offset(, x - 1).Value <> "" Then
                    For i = 1 To UBound(w(x + z))
                        tmp.Offset(, x - 1).Characters(Start:=i, Length:=1).Font.Color = w(x + z)(i)
                    Next
                End If
            Next
            Set tmp = tmp.Offset(1)
        Next

        Set pos = pos.Offset(dicB.Count)
    End If

    If dicC.Count > 0 Then
        pos.Resize(dicC.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicC.items))
    End If

    fSh.Parent.Close False

 End Sub

 Private Function GetColor(c As Range, z As Long)
    Dim w As Variant
    Dim v As Variant
    Dim x As Long
    Dim i As Long
    Dim col As Long
    ReDim w(1 To z * 2)
    With c.EntireRow
        For x = 1 To z
            w(x) = .Cells(1, x).Interior.Color
            If .Cells(1, x).Value <> "" Then
                ReDim v(1 To Len(.Cells(1, x).Text))
                For i = 1 To UBound(v)
                    v(i) = .Cells(1, x).Characters(Start:=i, Length:=1).Font.Color
                Next
            End If
            w(x + z) = v
        Next
    End With
    GetColor = w
 End Function

（β） 2015/05/08(金) 05:53

---

 もう１例。
 というか、最初は転記効率を考えてDictionaryや配列処理をとりいれたんですが、途中の背景色や文字色の復元追加時、
 その「思惑」は、かなり効果減になっていて、でも、最初の構成に小細工を施しただけ。
 で、今回の文字ごとの文字色復元でも、さらに小細工を施して、Test7 をアップ。

 でも、ここまでくれば、ベタベタと切り貼りしてもそんなに「効率の悪さ？」は変わらないので、切り貼りバージョンを。
 このほうが、コードが素直になるので。（上に押し上げられる行の順番がちょっと不安だけど）

 GetColor ルーティンは使いません。

 Sub Test8()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet
    Dim dicA As Object
    Dim dicB As Object
    Dim dicC As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Long
    Dim col As Variant

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicC = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, tSh.Range("A1", tSh.UsedRange).Columns.Count)
    '任意のブックのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicC(c.Value) = c.EntireRow.Range("A1").Resize(, z).Value
    Next
    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.Row   '任意ブックにもある
        Else
            dicA(c.Value) = c.Row   '任意ブックにはない
        End If
    Next
    '任意のブックのデータでマクロブックにもあるものをDicCから削除
    For Each k In dicC
        If dicA.exists(k) Or dicB.exists(k) Then
            dicC.Remove k
        End If
    Next

    pos = 5                         '切り貼り開始行

    If dicA.Count > 0 Then
        For Each col In dicA
            If dicA(col) <> pos Then
                tSh.Rows(dicA(col)).Cut
                tSh.Rows(pos).Insert shift:=xlDown
            End If
            pos = pos + 1
        Next

        tSh.Range("A5").Resize(dicA.Count, z).Interior.Color = vbYellow

    End If

    If dicC.Count > 0 Then
        tSh.Range("A5").Offset(dicA.Count + dicB.Count).Resize(dicC.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicC.items))
    End If

    fSh.Parent.Close False

 End Sub

（β） 2015/05/08(金) 07:04

---

 うまくいきました。
 大変ありがとうございました。
（ニワ） 2015/05/08(金) 20:55

---

 βさん，毎日使わせていただいています。
 ありがとうございます。

 それで，すみませんが，またお教え願います。
 自分でいろいろ研究したのですが，うまくいきませんでした。

 上記の　Test8　の方が動きが速いので，そちらを使ってみたいのですが，
 Test8には，上記の　 2015/04/19(日) 09:11　で質問して，Test5　で回答していただいた動作が
 含まれていないのです。
 Test8にTest5で回答していただいた動作も含めると，どうなりますでしょうか。

 本当に何度も申し訳ありませんが，よろしくお願いします。
　

（ニワ） 2015/05/24(日) 09:01

---

 横から失礼します。
 相当時間が経っていることでもあり、
 箇条書きで仕様をまとめていただけませんか？
 というのは、Test5以降の2015/04/26(日) 09:37 の議論はなぜ不要なのか。
 ああ、それも必要でした、とかは無しにして欲しいのです。
 回答者は機械じゃないので、できるだけ自分でも内容理解してほしいのです。

 一度まとめてご自分の言葉で表現してもらえませんか。
 今後、追加注文が無いように、よく考えていただけませんか？
 上記の作業をすることが、そうした思索の助けになるはずです。
 ファイナルアンサーならぬファイナルリクエストにしてもらいたいと思います。

（γ） 2015/05/24(日) 11:14

---

 γさんからも指摘があるように、あれを、追加して　とか、これをこうかえて　というには時間がたちすぎていて
 こちらも、どうだったっけ？何をどうしたらＯＫになるんだろうと、思い出すのに骨が折れますし、また、思い違いもでてくると思います。

 いったん、ここまでは伝えているよ　ということを忘れて、

 ・こういうレイアウトのものがある。
 ・そこで、こういう比較を行う
 ・比較結果が、■■■なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。
 ・比較結果が、○○○なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。
 ・比較結果が、□□□なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。

 こういったことを、「すべて網羅的に」整理してもらえませんか。

 >> Test8にTest5で回答していただいた動作も含めると，どうなりますでしょうか。

 Test8 でも、だいぶ時間が経過しています。ましてや、Test5で何をどのように実現していたか、こちらは（もうしわけありませんが）忘れてますので。

（β） 2015/05/24(日) 13:25

---

 どうもありがとうございます。
 下記のとおり、整理しました。
 それで、Test8に、下記の（９）の動作を加えていただきたいのです。
 よろしくお願いいたします。

 （１）フォルダに，Aというファイルがあり，C5〜C9セルに，あ，い，う，え，お，とデータが入っている。
 （２）同じフォルダに，任意の名称のファイルがあり，C5〜C10セルに，あ，う，お，か，き，く，とデータが入っている。
 （３）Aファイルと任意ファイルを比べると，任意ファイルの　か，き，く，の部分が追加されたデータになり，
 　　　Aファイルの　い，えの部分は，任意ファイルにはなく，いわゆる，はじかれるデータとなる。
 （４）Aファイル上でマクロを実行する。
 （５）任意ファイルの，か，き，く，がある行をコピーして，追加分として，Aファイル上の　お　のデータがある行の次の行に挿入する。
 （６）Aファイル上で，はじかれるデータである，い，え，がある行を，Aファイルの　あ　の行の前に移動して挿入する。
 （７）上記（６）で，はじかれて，上部に挿入した，い，え，の行について，A列からE列までのセルの色を黄色に変える。
 （８）追加で挿入したデータや，はじかれて上部に挿入したデータ以外の行について，ここでは，あ，う，お　が含まれる行について，
 　　　データの文字色やセル色を変更した場合，行が持ち上がっても色の変更を保持する。
 （９）上記の追加データやはじかれるデータ以外の行である，あ，う，お　が含まれる行について，
 　　　任意ファイル上のC列の　あ，う，お　のデータの右横のE列に，ア，ウ，オ　とデータが入っているとする。
 　　　このデータを，Aファイル上のC列の　あ，う，お　のデータの右横のE列にコピーして，貼り付ける。このとき，コピー元の文字色などは継承しない。
（ニワ） 2015/05/26(火) 16:46

---

このようなことですか？

 Sub TestC()
    Dim fName As Variant
    Dim fPath As String
    Dim fSh As Worksheet
    Dim tSh As Worksheet

    Dim dicB As Object
    Dim dicAonly As Object
    Dim dicBonly As Object
    Dim dicBoth As Object
    Dim c As Range
    Dim z As Long
    Dim k As Variant
    Dim pos As Long
    Dim col As Variant

    Application.ScreenUpdating = False

    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xlsx")
    If fName = "" Then
        MsgBox "フォルダ内に目的のブックがありません"
        Exit Sub
    End If

    Set dicB = CreateObject("Scripting.Dictionary")
    Set dicAonly = CreateObject("Scripting.Dictionary")
    Set dicBonly = CreateObject("Scripting.Dictionary")
    Set dicBoth = CreateObject("Scripting.Dictionary")

    Set tSh = ThisWorkbook.Sheets(1)
    Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
    'Set fSh = ThisWorkbook.Sheets(2) 'テスト用

    z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, _
                              tSh.Range("A1", tSh.UsedRange).Columns.Count)

    'ブックBのデータ格納
    For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
        dicB(c.Value) = c.Row   'ブックBにおける行番号
    Next

    ' 両者に共通するもの、ブックAのみのものを取得
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicB.exists(c.Value) Then
            dicBoth(c.Value) = dicB(c.Value) '両者に共通
        Else
            dicAonly(c.Value) = c.Row       'ブックAのみにあるもの
        End If
    Next

    'dicBonly: ブックBのみにある項目
    For Each k In dicB
        If dicBoth.exists(k) Then
            dicB.Remove k
        End If
    Next
    Set dicBonly = dicB

    pos = 5 '切り貼り開始行

    '(1)新規追加分 を下に追加する
    If dicBonly.Count > 0 Then
        tSh.Range("A5").Offset(dicAonly.Count + dicBoth.Count).Resize(dicBonly.Count, z).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicBonly.items))
    End If

    '(2)両者共通分についてE列の値を設定
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicBoth.exists(c.Value) Then
             c.Offset(0, 2).Value = fSh.Cells(dicBoth(c.Value), "E")
        End If
    Next

    '(3)Aのみのものについて、場所を入れ替え
    If dicAonly.Count > 0 Then
        For Each col In dicAonly
            If dicAonly(col) <> pos Then
                tSh.Rows(dicAonly(col)).Cut
                tSh.Rows(pos).Insert shift:=xlDown
            End If
            pos = pos + 1
        Next
        tSh.Range("A5").Resize(dicAonly.Count, z).Interior.Color = vbYellow
    End If

    fSh.Parent.Close False
 End Sub

 # 十分なテストを実行していないので、バグあったら失礼。
 # 殆どがβさんのパクリです。

（γ） 2015/05/27(水) 07:47

---

 どうもありがとうございます。
 何度も申し訳ありません。

 上記の　TestC　を試してみましたが，箇条書きで書いたうちの

 （５）任意ファイルの，か，き，く，がある行をコピーして，追加分として，Aファイル上の　お　のデータがある行の次の行に挿入する。

 のところがうまく動きませんでした。

 上記のTest8に，箇条書きで書いたうちの（９）の動作を加えたいのですが。

 これが，ファイナルリクエストなので，ご教示願います。

（ニワ） 2015/05/31(日) 11:03

---

 大変失礼しました。
 テスト不十分でした。
 これでどうですか？

 水曜日のことで、もうすっかり忘れているので、
 また間違っているかも知れないが、その折はそちらで対応願います。

 Sub TestD()
     Dim fName As Variant
     Dim fPath As String
     Dim fSh As Worksheet
     Dim tSh As Worksheet

     Dim dicB As Object
     Dim dicAonly As Object
     Dim dicBonly As Object
     Dim dicBoth As Object
     Dim c As Range
     Dim z As Long
     Dim k As Variant
     Dim pos As Long
     Dim col As Variant
     Dim m

     Application.ScreenUpdating = False

     fPath = ThisWorkbook.Path & "\"
     fName = Dir(fPath & "*.xlsx")
     If fName = "" Then
         MsgBox "フォルダ内に目的のブックがありません"
         Exit Sub
     End If

     Set dicB = CreateObject("Scripting.Dictionary")
     Set dicAonly = CreateObject("Scripting.Dictionary")
     Set dicBonly = CreateObject("Scripting.Dictionary")
     Set dicBoth = CreateObject("Scripting.Dictionary")

     Set tSh = ThisWorkbook.Sheets(1)
     Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
     '' Set fSh = ThisWorkbook.Sheets(2)

     z = WorksheetFunction.Max(fSh.Range("A1", fSh.UsedRange).Columns.Count, _
                               tSh.Range("A1", tSh.UsedRange).Columns.Count)

     'ブックBのデータ格納
     For Each c In fSh.Range("C5", fSh.Range("C" & Rows.Count).End(xlUp))
         dicB(c.Value) = c.Row
     Next

     ' 両者に共通するもの、ブックAのみのものを取得
     For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
         If dicB.exists(c.Value) Then
             dicBoth(c.Value) = dicB(c.Value) '両者に共通
         Else
             dicAonly(c.Value) = c.Row       'ブックAのみにあるもの
         End If
     Next

     'dicBonly: ブックBのみにある項目
     For Each k In dicB
         If dicBoth.exists(k) Then
             dicB.Remove k
         End If
     Next
     Set dicBonly = dicB

     '(1)新規追加分 を下に追加する
     k = dicAonly.Count + dicBoth.Count
     For Each m In dicBonly.items
         tSh.Range("A5").Offset(k).Resize(1, z).Value _
             = fSh.Cells(m, "A").Resize(1, z).Value
         k = k + 1
     Next

     '(2)両者共通分についてE列の値を設定
     For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
         If dicBoth.exists(c.Value) Then
              c.Offset(0, 2).Value = fSh.Cells(dicBoth(c.Value), "E")
         End If
     Next

     '(3)Aのみのものについて、場所を入れ替え
     pos = 5 '切り貼り開始行
     If dicAonly.Count > 0 Then
         For Each col In dicAonly
             If dicAonly(col) <> pos Then
                 tSh.Rows(dicAonly(col)).Cut
                 tSh.Rows(pos).Insert shift:=xlDown
             End If
             pos = pos + 1
         Next
         tSh.Range("A5").Resize(dicAonly.Count, z).Interior.Color = vbYellow
     End If

     fSh.Parent.Close False
 End Sub

（γ） 2015/05/31(日) 12:02

---

 実は Test8 を よく読んでいなかったのです。

    'マクロブックのデータを任意ブックにあるもの、ないものに分けて格納
    For Each c In tSh.Range("C5", tSh.Range("C" & Rows.Count).End(xlUp))
        If dicC.exists(c.Value) Then
            dicB(c.Value) = c.Row   '任意ブックにもある
 の次に
            c.Offset(0, 2).Value = dicC(c.Value)(1, 5)
 を追加するだけで良かったですね。

 βさん、質問者さん　失礼しました。   

# まだまだ手を入れるところがありそうです。
# 追加分だけを区別するようにしたいとか・・・・
# ただ、できるだけ簡単なものにしておくことをお勧めします。

（γ） 2015/05/31(日) 12:35

---

 できました。
 ありがとうございました。
（ニワ） 2015/06/02(火) 12:19

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.