[[20180305100811]]　『別シートの複数列のデータを転記』（＿）　ページの最後に飛ぶ

『別シートの複数列のデータを転記』（＿）

VBAで、一般的なカレンダ―のようなものに別シートのデータの日付をもとに転記するにはどうしたらよいのでしょうか。
各Sheetですが、Sheet1はカレンダーのような配置で日付の下に転記したい空白セルがあります。（日付の行は3,5,7,9,11,13行です。）
Sheet2は項目が1行目にあり2行目から下にデータがある一般的なデータ表です。
Sheet1の各日付行と、Sheet2の日付列（I列）が一致した場合、Sheet2の一致した日付行のB列、C列の文字を、Sheet1の一致した日付の下の一つのセル内にまとめて「B列文字列　C列文字列」のように空白を空けて転記したいです。
一致する日付が複数ある場合、

|B列文字列1　C列文字列1|
|B列文字列2　C列文字列2|

のように改行して同じセル内に追加していきたいです。

Sheet1の日付の入力形式ですが、月が替わるごとに日付も変更されるため、数式で入力し、表示形式を日付のみに設定しています。
Sheet2の日付はそのまま入力し○○○○/○○/○○と表示してます。

わかりづらい点があるかもしれませんが、よろしくお願い致します。

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

カレンダー自体は、曜日を抜くと、A3:G14の範囲です。
（＿） 2018/03/05(月) 10:50

 Sheet1

 	A	B	C	D	E	F	G
 2	日	月	火	水	木	金	土
 3					1	2	3
 4							
 5	4	5	6	7	8	9	10
 6							
 7	11	12	13	14	15	16	17
 8							
 9	18	19	20	21	22	23	24
 10							
 11	25	26	27	28	29	30	31
 12							
 13							
 14

 Sheet2					
 	B	C	D	…	I
 1	aaa	bbb	aaa　bbb　　2018/3/1
 2	ccc		ccc　　　　 2018/3/5

 Sheet2のD2:=TRIM(B1&"　"&C1)
 下方向にコピー

 Sheet1のA4:=IFERROR(SUBSTITUTE(INDEX(Sheet2!$D:$D,MATCH(A3,Sheet2!$I:$I,0)),"　",CHAR(10)),"")
 セルの書式設定→配置→「折り返して全体を表示する」にチェックを入れる
 G4までフィルコピー

 A4セルからG4セルをコピーして6、8、10、12、14行目に貼り付ける
（bi） 2018/03/05(月) 11:20

表示されている日付とされない日付があります。
また、日付が複数存在する場合2個目意向が表示されていません。
指示通りに行ったのですがなぜでしょうか。
（＿） 2018/03/05(月) 13:00

 ＞一致する日付が複数ある場合

 すみません。これを見落としていました。
 私のスキルでは無理なので他の方の回答をお待ちください。
（bi） 2018/03/05(月) 15:54

Sub main()

    Dim dic As Object, c As Range
    Set dic = CreateObject("Scripting.Dictionary")
    For Each c In Sheets("Sheet2").UsedRange.Cells
        If IsDate(c.Value) And c.Column = 9 Then
            dic(c.Value) = dic(c.Value) & vbLf & c.Offset(, -7).Value & Space(1) & c.Offset(, -6).Value
        End If
    Next c
    For Each c In Sheets("Sheet1").UsedRange.Cells
        If IsDate(c.Value) Then
            c.Offset(1).Value = dic(c.Value)
        End If
    Next c
End Sub
（mm） 2018/03/05(月) 16:54

bi様
いえいえ、こちらこそわざわざお時間を割いていただきありがとうございました。

mm様
ご回答ありがとうございます。
私のイメージしていたものが100%実現いたしました。
今回はわざわざお時間を割いていただきありがとうございました。
また何かあればお願い致します。

（＿） 2018/03/05(月) 17:32

度々失礼します。
上記のプログラムを実行し転記を行った際、データはうまく転記されるのですが、データの上に一文字分程度のスペースができてしまいます。
もちろん上詰めをしています。
「折り返して全体を表示する」に設定されていると起こるみたいです。
なにか対策はあるのでしょうか。
特に関係ないセルで「折り返して全体を表示」にしてもきちんと上詰めされます。
（＿） 2018/03/06(火) 10:26

申し訳ありません。
解決しました。初歩的な部分を見落としていました。

（＿） 2018/03/06(火) 10:39

度々失礼いたします。
先日頂いたプログラム中（少々変更しました）の、

For Each c In Sheets("Sheet3").UsedRange.Cells

  If IsDate(c.Value) And c.Column = 6 Then
     dic(c.Value) = dic(c.Value) & c.Offset(, -2).Value & Space(4) & c.Offset(, 1).Value &  Space(4) &  c.Offset(, -3).Value  & vbLf
        End If
    Next c

の部分なのですが、ここでは3つの列のデータを転記しているのですが、3つの列のデータをそれぞれ別の色に変えて転記、ということは可能でしょうか？
（＿） 2018/03/06(火) 17:13

コメント返信：

[ 一覧(最新更新順) ]

[[20180305100811]] 『別シートの複数列のデータを転記』（＿） ページの最後に飛ぶ

[[20180305100811]]　『別シートの複数列のデータを転記』（＿）　ページの最後に飛ぶ