0

以前、Excelに関して質問させていただいたものです。ベストアンサー期限が切れてしまい、ｺﾒﾝﾄできませんでしたがご回答頂いた方ありがとうございました。 ・shee2のD6〜D36日には日付が入力されています。（1〜31）数字のみ固定
・Worksheets("入力データ2").のB7～J7、B12～F12データ（数字）が入力されている。
マクロを実行すると、
Worksheets("入力データ").のM2に本日の日付のみを値のみ貼り付けします。
M2の値を読み、shee2のD6〜D36中から同じ値の列に
Offset(, 2)にWorksheets("入力データ2").のB7を
Offset(, 1)にWorksheets("入力データ2").のC7を
Offset(, 5)にWorksheets("入力データ2").のE12を値のみ貼り付けを行いたいです。


みなさんのを参考に作っては見たもののかなり長い行になってしまいました。（汗）
しかもcpyRnge15～19を飛ばしてマクロを実行します。（エラーメッセージ無し）
スペル間違い等は何度も見ましたがありませんし、cpyRnge18以降はしっかり実行している。（オフセットがずれているが。）
何か実行しない条件はありますか？

また、効率の良いﾏｸﾛがあればご教授下さい。

Sub ()
'
' Macro1
'

'日付をコピー→値のみ貼り付けする
Worksheets("入力データ").Range("L2").Select
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Dim tgtDate As String '日付文字
Dim cpyRnge1 As Range 'コピー範囲1
Dim cpyRnge2 As Range 'コピー範囲2
Dim cpyRnge3 As Range 'コピー範囲3
Dim cpyRnge4 As Range 'コピー範囲4
Dim cpyRnge5 As Range 'コピー範囲5
Dim cpyRnge6 As Range 'コピー範囲6
Dim cpyRnge7 As Range 'コピー範囲7
Dim cpyRnge8 As Range 'コピー範囲8
Dim cpyRnge9 As Range 'コピー範囲9
Dim cpyRnge10 As Range 'コピー範囲10
Dim cpyRnge11 As Range 'コピー範囲11
Dim cpyRnge12 As Range 'コピー範囲12
Dim cpyRnge13 As Range 'コピー範囲13
Dim cpyRnge14 As Range 'コピー範囲14
Dim cpyRnge15 As Range 'コピー範囲15
Dim cpyRnge16 As Range 'コピー範囲16
Dim cpyRnge17 As Range 'コピー範囲17
Dim cpyRnge18 As Range 'コピー範囲18
Dim cpyRnge19 As Range 'コピー範囲19
Dim cpyRnge20 As Range 'コピー範囲20
Dim cpyRnge21 As Range 'コピー範囲21
Dim pstCell1 As Range '貼付基準セル1


tgtDate = Worksheets("入力データ").Range("M2").Value
Set cpyRnge1 = Worksheets("入力データ２").Range("B18")
Set cpyRnge2 = Worksheets("入力データ２").Range("C18")
Set cpyRnge3 = Worksheets("入力データ２").Range("D18")
Set cpyRnge4 = Worksheets("入力データ２").Range("E18")
Set cpyRnge5 = Worksheets("入力データ２").Range("B7")
Set cpyRnge6 = Worksheets("入力データ２").Range("H18")
Set cpyRnge7 = Worksheets("入力データ２").Range("F18")
Set cpyRnge8 = Worksheets("入力データ２").Range("C7")
Set cpyRnge9 = Worksheets("入力データ２").Range("D8")
Set cpyRnge10 = Worksheets("入力データ２").Range("G18")
Set cpyRnge11 = Worksheets("入力データ２").Range("E8")
Set cpyRnge12 = Worksheets("入力データ２").Range("F8")
Set cpyRnge13 = Worksheets("入力データ２").Range("G8")
Set cpyRnge14 = Worksheets("入力データ２").Range("H8")
Set cpyRnge15 = Worksheets("入力データ２").Range("I7")
Set cpyRnge16 = Worksheets("入力データ２").Range("J7")
Set cpyRnge17 = Worksheets("入力データ２").Range("B12")
Set cpyRnge18 = Worksheets("入力データ２").Range("C12")
Set cpyRnge19 = Worksheets("入力データ２").Range("D12")
Set cpyRnge20 = Worksheets("入力データ２").Range("E12")
Set cpyRnge21 = Worksheets("入力データ２").Range("F12")
'日付検索(完全一致セル)↓
Set pstCell1 = Worksheets("sheet2").Range("D6:D36").Find(What:=tgtDate, LookAt:=xlWhole)


If Not pstCell1 Is Nothing Then
'コピー範囲をコピー↓
cpyRnge1.Copy
'貼付基準セルを再設定(日付列の隣)↓
Set pstCell1 = pstCell1.Offset(, 2)
'貼付基準セルを選択↓
Worksheets("sheet2").Select: pstCell1.Select
'値のみ貼付↓
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'コピーモード(点線囲み)解除
Application.CutCopyMode = False


'コピー範囲をコピー↓
cpyRnge2.Copy
'貼付基準セルを再設定(日付列の隣)↓
Set pstCell1 = pstCell1.Offset(, 1)
'貼付基準セルを選択↓
Worksheets("sheet2").Select: pstCell1.Select
'値のみ貼付↓
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'コピーモード(点線囲み)解除
Application.CutCopyMode = False

・・・以下cpyRnge21まで続く。

Else

MsgBox "指定の日付が存在しません。", vbExclamation + vbOKOnly, "エラー"


End If

End Sub

質問者が選んだベストソリューション

Yahoo!知恵袋 4196日前