エクセルのマクロ 選択したセルを指定した範囲へ値貼

質問

お世話になります。

自動記録したものをどのように修正したら、実行時に選択しているセルの値を、3行下、1つ左のセルから8行目までに貼り付けることができるよう書き変えられますでしょうか。

初心者で何に手を付けて良いのか分からず。どなたかご教示いただけませんでしょうか。どうぞよろしくお願い致します。

Sub 選択したセルを指定した範囲へ値貼り付け()
'
' Macro1 Macro
'

'
Range("I9").Select
Selection.Copy
Range("H12:H19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

回答No.8

kkkkkm · ベストアンサー

もしかして、コピー元の計算式が貼り付け先のセルを参照しませんか。

その場合は、エクセルの仕様かどうかは分かりませんが、計算した結果コピー元の値が変更されたら。計算より先にコピーしていてもコピーした値は変更されてしまいます。手動で一度コピーした後に貼り付け先のセルに一個ずつ貼り付けしてみてください。

ですので、コピー貼り付けではなくデータを変数(tmp)に入れてそれを代入する形にしました。

Sub 選択したセルを指定した範囲へ値代入個別()
Dim i As Long, flg As Boolean
Dim mRange As Range, tmp As Variant

If Selection.Column = 1 Then
MsgBox "A列を選択した状態では実行できません", vbInformation
Exit Sub
ElseIf Selection.Count <> 1 Then
MsgBox "複数のセルを選択した状態では実行できません", vbInformation
Exit Sub
End If
Set mRange = Selection
tmp = mRange.Value
For i = 0 To 7
flg = False
With mRange.Offset(3 + i, -1).Interior
If .ThemeColor = xlThemeColorDark1 Then
If .TintAndShade = -0.499984740745262 Then
flg = True
End If
End If
End With
If flg = False Then
mRange.Offset(3 + i, -1).Value = tmp
End If
Next
End Sub

お礼

長々とお付き合いいただきましたおかげで、
やりたかったことができました！
この度はどうもありがとうございました。

回答No.9

kkkkkm

コピー貼り付けを使いたい場合No6のコードに
以下のサイトを参考にして自動計算を一時オフにして最後にオンにするという方法を追加してください。
画面の再描画を停止するはしなくてもいいです。

http://yiaowang.web.fc2.com/programing/vba_xls_speedup/stop_auto.html

回答No.7

kkkkkm

> 0.8といった形で少しずつ少ない数値が貼り付けられました。

こちらではそのような現象は起こりません。コピーしたデータを順に貼り付けているだけですから。

mRange.Offset(3 + i, -1).Value = mRange.Value
でやってみたらどうなりますか。

回答No.6

kkkkkm

> 「選択した貼り付ける範囲のセルの色が灰色の場合は貼り付けない」

ふと思ったのですが、範囲の中で個別に対応するという事でしたら

Sub 選択したセルを指定した範囲へ値貼り付け個別()
Dim i As Long, flg As Boolean
Dim mRange As Range

If Selection.Column = 1 Then
MsgBox "A列を選択した状態では実行できません", vbInformation
Exit Sub
ElseIf Selection.Count <> 1 Then
MsgBox "複数のセルを選択した状態では実行できません", vbInformation
Exit Sub
End If
Set mRange = Selection
mRange.Copy
For i = 0 To 7
flg = False
With mRange.Offset(3 + i, -1).Interior
If .ThemeColor = xlThemeColorDark1 Then
If .TintAndShade = -0.499984740745262 Then
flg = True
End If
End If
End With
If flg = False Then
mRange.Offset(3 + i, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' ↑は↓でもよければ↓のほうが早いと思います。mRange.Copyもいらなくなります。
' mRange.Offset(3 + i, -1).Value = mRange.Value
End If
Next
End Sub

補足

ありがとうございます。

こちら試してみたところ、貼り付けられた数字が徐々に少なくなっていく現象が起きております。

0.5を貼り付けるようマクロを実行したら、
1.4
1.0
1.0
0.8といった形で少しずつ少ない数値が貼り付けられました。
ちなみに当初やりたかったことだった灰色のセルには貼り付けないようにはなってくれています！

回答No.5

kkkkkm

No4の訂正です。
先頭だとA列を選択したときにエラーになるので

Sub 選択したセルを指定した範囲へ値貼り付け()
Dim i As Long

If Selection.Column = 1 Then
MsgBox "A列を選択した状態では実行できません", vbInformation
Exit Sub
ElseIf Selection.Count <> 1 Then
MsgBox "複数のセルを選択した状態では実行できません", vbInformation
Exit Sub
End If
For i = 0 To 7
With Selection.Offset(3 + i, -1).Interior
If .ThemeColor = xlThemeColorDark1 Then
If .TintAndShade = -0.499984740745262 Then
MsgBox "指定色で塗りつぶされたセルに貼り付けはきません", vbInformation
Exit Sub
End If
End If
End With
Next
Selection.Copy
Selection.Offset(3, -1).Resize(8, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

補足

私の説明が下手でした。

貼り付ける範囲のセルは、黄色か灰色です。
灰色へは貼り付けたくなく、黄色のセルだけ貼り付けたかったのですが、頂いたコードですと、一つも貼り付けできず、
「"指定色で塗りつぶされたセルに貼り付けはきません"」とmsgBoxで出てきてしまいます。

回答No.4

kkkkkm

> 「選択した貼り付ける範囲のセルの色が灰色の場合は貼り付けない」

一番先頭に以下を追加してみてください。
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.499984740745262
はマクロの記録で実際にその色でセルを塗りつぶしてコードを取得してください。

Dim i As Long

For i = 0 To 7
With Selection.Offset(3 + i, -1).Interior
If .ThemeColor = xlThemeColorDark1 Then
If .TintAndShade = -0.499984740745262 Then
MsgBox "指定色で塗りつぶされたセルに貼り付けはきません", vbInformation
Exit Sub
End If
End If
End With
Next

回答No.3

kkkkkm

> ちなみにこの実行を間違えて行ってしまった場合、戻るボタンが押せないのですが、これはエクセルの性質上できないものなのでしょうか・・・

はい、マクロの実行の結果は元に戻せません。
また、チップでのメッセージだと見逃す場合(通知ではチップのお知らせをクリックして確認しないと分からないので)がありますので、補足などに記載したほうがいいと思います。

回答No.2

kkkkkm

選択セルを1個に限定するのでしたら

Sub 選択したセルを指定した範囲へ値貼り付け()
If Selection.Column = 1 Then
MsgBox "A列を選択した状態では実行できません", vbInformation
Exit Sub
ElseIf Selection.Count <> 1 Then
MsgBox "複数のセルを選択した状態では実行できません", vbInformation
Exit Sub
Else
Selection.Copy
Selection.Offset(3, -1).Resize(8, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub

補足

お陰様で動作させることができました。
ありがとうございます。

この操作に出来れば1つ操作を加えたいことがあります。
「選択した貼り付ける範囲のセルの色が灰色の場合は貼り付けない」ということが出来たらよいのですが。

色は、マウスポインタを合わせたところ「白、背景1、黒+基本色50％」　となっています。

もし出来るようでしたらお助けいただけますと幸いです。

どうぞよろしくお願い致します。

回答No.1

kkkkkm

以下で試してみてください。

Sub 選択したセルを指定した範囲へ値貼り付け()
If Selection.Column = 1 Then
MsgBox "A列を選択した状態では実行できません", vbInformation
Exit Sub
Else
Selection.Copy
Selection.Offset(3, -1).Resize(8, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub