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

Results of 1 - 1 of about 37686 for IF (0.007 sec.)

[[20150409161816]]: #score: 1591; @digest: 1d0bf0a5a02e8a3eb72e00f52e472343; @id: 67738; @mdate: 2015-06-02T03:19:58Z; @size: 45227; @type: text/plain; #keywords: 意ブ (154979), dicaonly (114259), dicboth (101754), fsh (93459), dicc (85781), dicbonly (76172), dicb (71085), tsh (70708), ニワ (68142), 意フ (66273), dica (52329), 納fo (29082), fpath (27326), fname (19031), pos (19011), 任意 (15164), 字色 (13290), worksheetfunction (12301), scripting (11848), transpose (11397), dictionary (10968), entirerow (10906), に, (10000), て, (9640), items (9386), ロブ (9320), ル上 (8731), createobject (8700), exists (8678), usedrange (7635), count (7317), ブッ (7167); 『最新のデータだけ追記する』（ニワ）
フォルダに,Aというファイルがあります。 Aファイルの3列目,5行目以降,つまり,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セルに,1,2,3,4,5,とデータが入っています。また,任意ファイルのC5〜C10セルに,あ,う,お,か,き,く,とデータが, B5〜B10セルに,ア,ウ,オ,カ,キ,クとデータが入っています。 D列のセルにはデータが入っていません。この条件で,上記Test4のマクロを実行すると,「Aファイル上で」,いえのデータ（任意のファイルのデータあうおかきくと比べて,はじかれるもの）は前に出て,黄色になります。さらに,いえのデータの左横にあるイエのデータも前に出て,黄色になります。しかし,いえのデータの右横にある 2,4 のデータは前に出ません。 D5〜D9セルのデータは,1,2,3,4,5,と並んだままです。これを,い,えのデータが含まれる行ごと前に出るようにしたいのですが,いかがでしょうか（ニワ） 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行目、6行目の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 ---- うまくできました。列の数の違いに対応できました。すみませんが,もう1つお教え願います。今までのことを整理すると, Aファイル上でか,き,くのデータを含む行が新しく挿入されるい,えのデータを含む行がはじかれて,上部に移動して黄色になります。それで,残りのあうおのデータを含む行についてです。任意ファイル上で,C5〜C7セルに,あ,う,お,とデータが, そして,E5〜E7セルに,（ア）,（ウ）,（オ）,とデータが入っているとします。この（ア）,（ウ）,（オ）のデータを,Aファイル上の対応するあうおのデータの右横のE7〜E9セルに貼り付けるということを,上記Test4のマクロに加えたいのですが,いかがでしょうか。要するに,任意ファイルのデータの中で,Aファイルと比べて,新規追加やはじかれるデータにならないデータについて対応するE列のデータを,Aファイル上の対応するE列に貼り付けるとしたいのですが,いかがでしょうか。（ニワ） 2015/04/19(日) 09:11 ---- こういうことですか? で、仮に、このコードが要件の誤解なくOKだったとします。でも、今後、あれも、こうしたい、これも、ああしたいと、そういったことがあった都度、質問をアップされますか? もちろん、目に留まれば、その時もお手伝いはしますが、やはり、コードの各行で、何をしているのか、それを、しっかりと理解しておいてほしいですね。そうすれば、少しは自助努力で、今後の追加改定に対応できるかもしれませんので。 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 ---- どうもありがとうございます。もう1つ不具合がありまして。いろいろ研究しましたが,よく分からないので,申し訳ありませんが,お教え願います。 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 ---- もう1例。というか、最初は転記効率を考えて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 ---- γさんからも指摘があるように、あれを、追加してとか、これをこうかえてというには時間がたちすぎていてこちらも、どうだったっけ?何をどうしたらOKになるんだろうと、思い出すのに骨が折れますし、また、思い違いもでてくると思います。いったん、ここまでは伝えているよということを忘れて、・こういうレイアウトのものがある。・そこで、こういう比較を行う・比較結果が、■■■なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。・比較結果が、○○○なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。・比較結果が、□□□なら、それを、どこそこに、このように（背景色や文字ごとの文字色の説明も含めて）セット。こういったことを、「すべて網羅的に」整理してもらえませんか。 >> Test8にTest5で回答していただいた動作も含めると,どうなりますでしょうか。 Test8 でも、だいぶ時間が経過しています。ましてや、Test5で何をどのように実現していたか、こちらは（もうしわけありませんが）忘れてますので。（β） 2015/05/24(日) 13:25 ---- どうもありがとうございます。下記のとおり、整理しました。それで、Test8に、下記の（9）の動作を加えていただきたいのです。よろしくお願いいたします。（1）フォルダに,Aというファイルがあり,C5〜C9セルに,あ,い,う,え,お,とデータが入っている。（2）同じフォルダに,任意の名称のファイルがあり,C5〜C10セルに,あ,う,お,か,き,く,とデータが入っている。（3）Aファイルと任意ファイルを比べると,任意ファイルのか,き,く,の部分が追加されたデータになり, Aファイルのい,えの部分は,任意ファイルにはなく,いわゆる,はじかれるデータとなる。（4）Aファイル上でマクロを実行する。（5）任意ファイルの,か,き,く,がある行をコピーして,追加分として,Aファイル上のおのデータがある行の次の行に挿入する。（6）Aファイル上で,はじかれるデータである,い,え,がある行を,Aファイルのあの行の前に移動して挿入する。（7）上記（6）で,はじかれて,上部に挿入した,い,え,の行について,A列からE列までのセルの色を黄色に変える。（8）追加で挿入したデータや,はじかれて上部に挿入したデータ以外の行について,ここでは,あ,う,おが含まれる行について, データの文字色やセル色を変更した場合,行が持ち上がっても色の変更を保持する。（9）上記の追加データやはじかれるデータ以外の行である,あ,う,おが含まれる行について, 任意ファイル上の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 を試してみましたが,箇条書きで書いたうちの（5）任意ファイルの,か,き,く,がある行をコピーして,追加分として,Aファイル上のおのデータがある行の次の行に挿入する。のところがうまく動きませんでした。上記のTest8に,箇条書きで書いたうちの（9）の動作を加えたいのですが。これが,ファイナルリクエストなので,ご教示願います。（ニワ） 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 ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/201504/20150409161816.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ