VBA 毎回データが違っても応用できるコード

質問

O列をフィルタで昇順にして、2以上の数値（#N/Aも含む）をコピーして同じ行のQ列に値でペーストするといった流れです。
下記のコードはマクロで記録で作成したものです。

Range("O632:O705").Select
O632から最後尾のO705までのセルをコピー
 Range("Q632").Select
同じ行のQ632セルを選択し、値でペーストする。

データは毎回バラバラなので
(O400～O800だったり)、応用できるコードを教えて頂けないでしょうか？
宜しくお願いします。

    ActiveWorkbook.Worksheets("シート1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("シート1").AutoFilter.Sort.SortFields.Add Key:= _
        Range("O1:O705"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("シート1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Range("O632:O705").Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-48
    Range("Q632").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=56
End Sub

回答No.3

o_chi_chi

最初の行の判定は情報不足で解りません。

＞O632から最後尾のO705までの
O631までが空白なら
s = Range("O1").End(xlDown).Row 'データの最初
e = Range("O" & s).End(xlDown).Row 'データの最後
Range("O" & s & ": O" & e).Select
で選択できます。

お礼

すみません。
締め切って再度質問しますので、宜しくお願いします。

補足

ありがとうございます。

すみません、手順が違っていましたので、修正しました。
O列をフィルタで昇順にします。
2以上の数値（#N/Aも含む）が入った行のP列をコピーして同じ行のQ列に値でペーストするといった流れです。
見やすくするため、ペーストしたものは赤い文字にしてくれたらありがたいです。
宜しくお願いします。

O列　　 P列 Q列
2 79 79
2 79 79
3 #N/A #N/A
4 #N/A #N/A
5 80 80
8 80 80
8 80 80
10 80 80
11 80 80
18 #N/A #N/A
#N/A 84 84
#N/A 80 80
↑　　　↑
コピー　　値でペースト

回答No.2

HohoPapa

やりたいことが
>2以上の数値（#N/Aも含む）をコピーし、
>同じ行のQ列に値でペーストする
ことで、

その手段として
>O列をフィルタで昇順にして
その後必要な範囲をコピー＆ペーストしているということでしょうか。

つまり、単に
O列を2行目から下方向に調べ
>2以上の数値（#N/Aも含む）
があったら、
それを同じ行のQ列に値を複写すればいいんですね？

ならば、関数でもできそうですが
VBAであれば、

Sub Sample()

　Dim RowCounter As Long

　With ThisWorkbook.Sheets(1)

　　.Columns(17).ClearContents
　　RowCounter = 2

　　Do

　　　If IsError(.Cells(RowCounter, 15).Value) = False Then
　　　　If .Cells(RowCounter, 15).Value = "" Then
　　　　　Exit Do
　　　　End If
　　　End If

　　　If IsError(.Cells(RowCounter, 15).Value) = True Then
　　　　.Cells(RowCounter, 17).Value = _
　　　　.Cells(RowCounter, 15).Value
　　　ElseIf .Cells(RowCounter, 15).Value >= 2 Then _
　　　　.Cells(RowCounter, 17).Value = _
　　　　.Cells(RowCounter, 15).Value
　　　End If

　　　RowCounter = RowCounter + 1

　　Loop

　End With

End Sub

でいかがでしょうか。

お礼

すみません。
締め切って再度質問しますので、宜しくお願いします。

補足

ありがとうございます。

すみません、手順が違っていましたので、修正しました。
O列をフィルタで昇順にします。
2以上の数値（#N/Aも含む）が入った行のP列をコピーして同じ行のQ列に値でペーストするといった流れです。
見やすくするため、ペーストしたものは赤い文字にしてくれたらありがたいです。
宜しくお願いします。

O列　　 P列 Q列
2 79 79
2 79 79
3 #N/A #N/A
4 #N/A #N/A
5 80 80
8 80 80
8 80 80
10 80 80
11 80 80
18 #N/A #N/A
#N/A 84 84
#N/A 80 80
↑　　　↑
コピー　　値でペースト

回答No.1

watabe007

>2以上の数値（#N/Aも含む）をコピーして同じ行のQ列に値でペーストする
最初にO列の最終行を検出します。
Dim LR As Long, i As Long
LR = Cells(Rows.Count, "O").End(xlUp).Row
次に
> Range("O1:O705"), SortOn:=xlSortOnValues, Order:=xlAscending,
　　　　↓
Range("O1:O" & LR), SortOn:=xlSortOnValues, Order:=xlAscending,
次は
>Range("O632:O705").Select
>Selection.Copy
>ActiveWindow.SmallScroll Down:=-48
>Range("Q632").Select
>Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
> :=False, Transpose:=False
> ActiveWindow.SmallScroll Down:=56
> End Sub
　　　　↓
　　For i = 1 To LR
　　　　If Cells(i, "O").Value >= 2 Then Exit For
　　Next
　　Range(Cells(i, "O"), Cells(LR, "O")).Copy
　　Cells(i, "Q").PasteSpecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
End Sub

お礼

すみません。
締め切って再度質問しますので、宜しくお願いします。

補足

ありがとうございます。

すみません、手順が違っていましたので、修正しました。
O列をフィルタで昇順にします。
2以上の数値（#N/Aも含む）が入った行のP列をコピーして同じ行のQ列に値でペーストするといった流れです。
見やすくするため、ペーストしたものは赤い文字にしてくれたらありがたいです。
宜しくお願いします。

O列　　 P列 Q列
2 79 79
2 79 79
3 #N/A #N/A
4 #N/A #N/A
5 80 80
8 80 80
8 80 80
10 80 80
11 80 80
18 #N/A #N/A
#N/A 84 84
#N/A 80 80
↑　　　↑
コピー　　値でペースト