比較して一致したら指定セルに貼り付け処理

質問

【Sheet1】の日付A1セルと【Sheet2】の日付A行を比較。
※ 【Sheet1】の比較元はA1だけでいい

一致しなければ【Sheet2】のA行を一つ下げ、比較し直し、一致するまで比較
一致したら【Sheet1】のA列以降を全てコピーし【Sheet2】の一致した日付の隣B列に以下の様に貼り付けする

【Sheet1】　　　　　　　　　　　　【Sheet2】
　　　　A　　　　　　　　B 　 C 　　 　　 A
1　2008/1/2 0:45 　72　　99　　　1　2008/1/2 0:00
2　2008/1/2 1:00 　76　　84　　　2　2008/1/2 0:15
3　2008/1/2 1:15 　19　　45　　　3　2008/1/2 0:30
4　2008/1/2 1:30 　30　　78　　　4　2008/1/2 0:45
5　2008/1/2 1:45 　56　　33　　　5　2008/1/2 1:00
↓『結果』
【Sheet2】
　　　A　　　　　　　　　　B
1　2008/1/2 0:00
2　2008/1/2 0:15
3　2008/1/2 0:30
4　2008/1/2 0:45　　2008/1/2 0:45 72 99
5　2008/1/2 1:00　　2008/1/2 1:00 76 84
6　2008/1/2 1:15　　2008/1/2 1:15 19 45
7　2008/1/2 1:30　　2008/1/2 1:30 30 78
8　2008/1/2 1:45　　2008/1/2 1:45 56 33

--------------------------------------------------------------------------
Dim i As Integer
Dim Com As Integer
Dim s As Integer

SheetName = "Sheet1"
SheetName2 = "Sheet2"

Do
For Com = 1 To 20
' Sheet1のA1とSheet2のA行セルが一致するまで比較
If StrComp(Worksheets(SheetName).Cells(1, 1), Worksheets(SheetName2).Cells(Com, 1), vbTextCompare) Then
' 一致したらA列をコピー
Rows("1:1").Select
Selection.Copy
Else
' 一致しなければSheet2のAセルを一つ下げる
WorkSheets(SheetName2).Cells(Com, 1).Offset(1, 0).Select
End If
Next
' 一致するまで比較
Loop Until StrComp(Cells(1, 1), Cells(s, 10))

--------------------------------------------------------------------------
Loop Untilの箇所で記述がおかしいせいかアプリケーション定義、またはオブジェクトエラーになってしまいます。

一致した時、Sheet1のA1列の情報をSheet2の指定箇所に格納する記述の仕方がどうしてもわかりません。
何かいい記述はないでしょうか？
質問が長くなってしまいましたが、どうか教えていただきたく思います。
よろしくお願いします。

回答No.2

zap35 · ベストアンサー

サンプルマクロです。
StrComp関数を使用しているから、Ａ列の「日付＋時刻」が文字列で入力されているのでしょうか。その場合は
Sub Macro1()
Dim idx As Long
Dim res
With Sheets("Sheet2")
　　For idx = 1 To Sheets("Sheet1").Range("A65536").End(xlUp).Row
　　　　res = Application.Match(Sheets("Sheet1").Cells(idx, "A").Value, _
　　　　　　　　.Range(.Range("A1"), .Range("A65536").End(xlUp)), 0)
　　　　If IsNumeric(res) Then
　　　　　　Sheets("Sheet1").Cells(idx, "B").Resize(1, 2).Copy .Cells(res, "B")
　　　　End If
　　Next idx
End With
End Sub

もしＡ列の「日付＋時刻」が日付型で入力されている場合はこうなります
Sub Macro2()
Dim idx As Long
Dim res
With Sheets("Sheet2")
　　For idx = 1 To Sheets("Sheet1").Range("A65536").End(xlUp).Row
　　　　res = Application.Match(CDbl(Sheets("Sheet1").Cells(idx, "A").Value), _
　　　　　　　　.Range(.Range("A1"), .Range("A65536").End(xlUp)), 0)
　　　　If IsNumeric(res) Then
　　　　　　Sheets("Sheet1").Cells(idx, "B").Resize(1, 2).Copy .Cells(res, "B")
　　　　End If
　　Next idx
End With
End Sub

回答No.1

nobu555

マクロは、まだまだ半人前ですが
勉強がてら調べてみました。

>Loop Untilの箇所で記述がおかしいせいか…
変数sを設定されていますが
値が代入されていません。

iも宣言してますが使用されてません。
（一部なので他で出てくるのでしょか？）

StrComp関数は、比較して一致したとき
戻り値が"0"となりますので、
真偽が逆になります。

>If StrComp() Then
>' 一致したらA列をコピー
>Else
>' 一致しなければSheet2のAセルを一つ下げる
>End If

ではなく、

If StrComp() Then
' 一致しなければSheet2のAセルを一つ下げる
Else
' 一致したらA列をコピー
End If

となると思います。

コードにカーソルを合わせて
ファンクションキー「F1」を押すと
ヘルプが現れます。

とりあえず、自分なりに作ってみました。
Sub TEST()

Dim Com As Integer

SheetName = "Sheet1"
SheetName2 = "Sheet2"
LastRow = Worksheets(SheetName2).Range("A65536").End(xlUp).Row

For Com = 1 To LastRow
' Sheet1のA1とSheet2のA行セルが一致するまで比較
If StrComp(Worksheets(SheetName).Cells(1, 1), Worksheets(SheetName2).Cells(Com, 1), vbTextCompare) Then
Else
' 一致したらA列をコピー
Sheets("Sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(Com, 2).Select
ActiveSheet.Paste
Exit For

End If
Next

End Sub