VBA Do Until内で値の貼り付けができない

質問

Excel2003を使用しております。

コピー&値のペースト作業をやってくれるマクロを作成しております。
具体的には、名簿に公がついていれば、その３つ左の名前をD27へ値のみコピペし、
D27がすでに値があれば、D28に書くことを、D37までループするようにしております。
しかし困ったことに、Do Untilコードを使用しておりますが、このコードではなぜか値の貼り付けが出来なくなります。

Sub Ns公()
Dim work As Range
Set work = Selection
If Selection.Value = "公" Then
ActiveCell.Offset(0, -3).Select
Selection.Copy
Do Until Range("D37").Select
Range("D27").Select
If Selection.Value = "" Then
Selection.PasteSpecial paste:=xlPasteValues
work.Select
Else
ActiveCell.Offset(1).Select
End If
Loop
If Range("D36").Value <> "" Then
Do Until Range("I37").Select
Range("I27").Select
If Selection.Value = "" Then
Selection.PasteSpecial paste:=xlPasteValues
work.Select
Else
ActiveCell.Offset(1).Select
End If
Loop
work.Select
End If
work.Select
End If
work.Select
ActiveCell.Offset(1).Select
End Sub

原因や対策をご教授いただけるとうれしいです。よろしくお願いします。

回答No.1

mt2008 · ベストアンサー

本当は、「ここをこう直す」と言う感じでアドバイスできればよかったんですが、Selectを多用されているので追いづらくって断念しました。
代わりに、提示された説明とコードから、こういうことがしたいのかなと推測して作ってみました。

Sub Sample()
　　Dim nRow As Long
　　If Selection.Value = "公" Then
　　　　'値貼り付け位置を確認
　　　　nRow = Range("D38").End(xlUp).Row
　　　　If nRow = 37 Then
　　　　　　MsgBox ("D37まで書き込み済み")
　　　　　　Exit Sub
　　　　ElseIf nRow < 27 Then
　　　　　　nRow = 26
　　　　End If
　　　　'値をD27以下の空セルに代入
　　　　Range("D" & nRow + 1) = ActiveCell.Offset(0, -3).Value
　　End If
　　'選択セルを一行下げる（元から入っているので残しました）
　　ActiveCell.Offset(1).Select
End Sub

VBAで値のコピーをする場合、いちいちSelectする必要はありません。
まずはSelection.CopyとSelection.Pasteを使わないコードを目指しましょう。

お礼

ご丁寧にありがとうございます。
このままコピーで使用できます（感動）

お忙しいところ
ありがとうございました！！