Excel VBA 条件指定による別シートの参照について

質問

下記のように、Excelでマクロを組みたいのですが
組み方がわかりません。
この組方さえわかれば、仕事の便利なツールがいろいろ
作れますので、ご協力いただけませんでしょうか？

シートA、シートBがある

シートA

日時 　曜日 名前 時間　 内容 　TEL 　完了日時
7月1日 水 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　終日 　正常 　無し
　　　　　　　　ccc 　終日 　正常 　無し
7月2日 木 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　終日 　正常 　無し
　　　　　　　　ccc 　終日 　正常 　無し
7月3日 金 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　終日 　正常 　無し
　　　　　　　　ccc　 終日　 正常　 無し

シートB

5月2日 木 　aaa 　11:00 　エラー 有り 11:30
7月2日 木 　bbb 　11:00 　エラー 有り 11:30

シートAにマクロをくみ、シートBを参照して、シートA'を作成したい。
(シートAがシートA'のようになればよく、新規にファイルを作成したり
リネームする必要は無い)

シートA'

日時 　曜日 名前 時間　 内容 　TEL 　完了日時
7月1日 水 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　終日 　正常 　無し
　　　　　　　　ccc 　終日 　正常 　無し
7月2日 木 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　11:00　エラー 有り 11:30
　　　　　　　　ccc 　終日 　正常 　無し
7月3日 金 　aaa 　終日 　正常 　無し
　　　　　　　　bbb 　終日 　正常 　無し
　　　　　　　　ccc　 終日　 正常　 無し

どのようにマクロをくめばよいですか？
数ヶ月前から困っています。
よろしくお願いいたします。

回答No.2

Wendy02

こんにちは。

最近、似たような質問がありましたが、Accessとは違いますますから、Excelでは、「正規化」は、ちょっと痛いですね。

http://oshiete1.goo.ne.jp/qa5106303.html
#8 のようにすると、「正規化」しなかったら、もう少し簡単になったと思うのですが……。

私は、一旦、すべて、配列変数の中に入れて処理させます。なお、書き換えても、それほどには実害がないとは思いますが、一旦、バックアップか、保存をしてから、マクロを実行してください。

Aシートと、Bシートの名前の部分の比較も、不安があります。おそらく、どちらも手入力ですから、失敗があるかもしれません。

'-------------------------------------------
'Option Explicit

Sub Test1()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim r As Range
　　Dim r2 As Range
　　Dim i As Long, j As Long, k As Long
　　Dim n As Long, m As Long
　　Dim buf1 As Variant
　　Dim buf2 As Variant
　　Dim ar() As Variant
　　Dim ari() As Long
　　Set sh1 = Worksheets("Sheet1") 'データ基本シート
　　Set sh2 = Worksheets("Sheet2") 'エラーシート

　　Const iRW As Integer = 2 'データ初期行（タイトルを抜く)
　　Const sERR As String = "A1" 'エラーシート・左端上初期アドレス

　　With sh1
　　　　Set r = .Range(.Cells(iRW, 1), .Cells(Rows.Count, 3).End(xlUp).Offset(, 4))
　　　　ReDim ar(r.Rows.Count - 1, r.Columns.Count - 1)
　　　　With r
　　　　　　For i = 1 To r.Rows.Count
　　　　　　If .Cells(i, 1).Value <> "" Then buf1 = .Cells(i, 1).Value: buf2 = .Cells(i, 2).Value
　　　　　　　　j = i - 1
　　　　　　　　ar(j, 0) = buf1: ar(j, 1) = buf2: ar(j, 2) = .Cells(i, 3).Value
　　　　　　　　ar(j, 3) = .Cells(i, 4).Value: ar(j, 4) = .Cells(i, 5).Value
　　　　　　　　ar(j, 5) = .Cells(i, 6).Value: ar(j, 6) = .Cells(i, 7).Value
　　　　　　Next i
　　　　End With
　　End With
　　With sh2
　　　　Set r2 = .Range(sERR, .Cells(Rows.Count, 1).End(xlUp).Offset(, 6))
　　　　With r2
　　　　　　For i = 1 To .Rows.Count
　　　　　　　　For j = LBound(ar, 1) To UBound(ar, 1)
　　　　　　　　　　'日付と文字の比較（難あり)
　　　　　　　　　　If ar(j, 0) = .Cells(i, 1).Value And Trim(ar(j, 2)) = Trim(.Cells(i, 3).Value) Then
　　　　　　　　　　　　ReDim Preserve ari(1, k)
　　　　　　　　　　　　ari(0, k) = j: ari(1, k) = i: k = k + 1
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　Next i
　　　　End With
　　End With
　　If ari(0, 0) = 0 Then
　　　　MsgBox "該当するエラーデータがありません。", vbExclamation
　　　　Exit Sub
　　End If
　　With sh1
　　　　Application.ScreenUpdating = False
　　　　For i = LBound(ari, 2) To UBound(ari, 2)
　　　　　　m = ari(0, i): n = ari(1, i)
　　　　　　r.Cells(m + 1, 3).Value = r2.Cells(n, 3)
　　　　　　r.Cells(m + 1, 4).NumberFormatLocal = r2.Cells(n, 4).NumberFormatLocal
　　　　　　r.Cells(m + 1, 4).Value = r2.Cells(n, 4)
　　　　　　r.Cells(m + 1, 5).Value = r2.Cells(n, 5)
　　　　　　r.Cells(m + 1, 6).Value = r2.Cells(n, 6)
　　　　　　r.Cells(m + 1, 7).NumberFormatLocal = r2.Cells(n, 7).NumberFormatLocal
　　　　　　r.Cells(m + 1, 7).Value = r2.Cells(n, 7)
　　　　Next i
　　　　Application.ScreenUpdating = True
　　End With
　　Set sh1 = Nothing: Set sh2 = Nothing
　　Set r = Nothing: Set r2 = Nothing
End Sub

'-------------------------------------------

お礼

ありがとうございます。
事情があって本日は試せないので、明日か明後日に確認します。
感謝感謝です！！

回答No.1

mt2008

条件が良く判りません。
シートA/Bに同じ日付があった場合はシートBのデータが優先？
表示対象はシートAで表示されている月のみが対象？

補足

説明が下手ですみません。

シートBを基準に、毎日のエラー報告書を月単位で作成したいのです。
シートBのデータで、エラーが発生していない日は、[aaa 　終日 　正常 　無し]を追加したいのですがわかりますか？
すみません

シートBにエラーがある日は、aaa～cccの該当する名前の場所に、その内容、エラーがない日は、aaa～cccに[終日 　正常 　無し]という表を作成したいです。

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