みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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  終日  正常  無し

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

投稿日時 - 2009-07-10 00:46:49

QNo.5113054

困ってます

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

こんにちは。

最近、似たような質問がありましたが、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

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

投稿日時 - 2009-07-11 10:38:24

お礼

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

投稿日時 - 2009-07-11 11:59:04

ANo.1

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

投稿日時 - 2009-07-10 09:16:59

補足

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

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

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


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

投稿日時 - 2009-07-11 00:27:16

あなたにオススメの質問