【Excel】コメント一括抽出

Question

Excelのコメントを他のシートに書き出したいと考えてします。
一行だけ抽出するのは以下で出来ているのですが
ある程度の範囲(例えばJ15:AN232)を一括で抽出するには
どのようにすればいいでしょうか。

---

Sub コメント抽出()

Const C As Integer = 5 
Const D As Integer = 9
Dim FR As Variant
Dim LR As Variant
Dim R As Variant

FR = 3
LR = 300

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For R = FR To LR

    Cells(R, D).Value = Cells(R, C).NoteText
   
Next R

ActiveSheet.Range("A1").AutoFilter Field:=9, Criteria1:="<>"

MsgBox "抽出しました"

Application.ScreenUpdating = Ture
Application.Calculation = xlCalculationAutomatic

End Sub

ご教授よろしくお願い致します。

Comments

[ttyp03]

抽出先はどこになりますか？現状のコードでは5列目を対象に9列目に書き出しているようですが。

[退会済みユーザー]

ありがとうございます。
別のシート(例えばシート名が「抽出」)の任意の範囲にしたいと考えています。

Answer 1

Rangeを使って範囲指定すれば一括でコピー可能ですよ。
注意事項としてはコピー先もコピー元と同じ広さの範囲を指定する必要があります。
特に指定されてないのでコピー先は仮ですが。

' A1形式
Range("J300:AN517").Value = Range("J15:AN232").NoteText
' Cells指定
Range(Cells(300, 10), Cells(517, 40)).Value = Range(Cells(15, 10), Cells(232, 40)).NoteText

Comments

[退会済みユーザー]

Range(Cells(15, 78), Cells(232, 109)).Value = Range(Cells(15, 10), Cells(232, 41)).NoteText

で試しましたが抽出されないようです…。
何か過不足があるのでしょうか。

[退会済みユーザー]

ちなみに

Range("E1:G3").Value = Range("A1:C3").NoteText

でテストをすると「A1」のコメントのみが「A1:C3」に出力されます。

[yureighost]

そのコード部分のみでテストされてますか？
別なところも含めているならその部分のソースを張り直してください。

[退会済みユーザー]

このコードのみでテストしています。
お手数をおかけして申し訳ありません。

[yureighost]

こちらではこのコードでそう言った動作をしないので確認が難しいのですが。

Answer 2

こんなコードでいかがでしょう
対象始点セルから終点までの範囲にあるコメントをすべてコメント貼り付け対象のセルA列に出力しB列にアドレスを貼り付けます。

Sub test()
対象シート = "Sheet1"
コメント貼り付け対象 = "Sheet2"
範囲始点 = "A1"
範囲終点 = "X100"
j = 0

Application.ScreenUpdating = False
Sheets(対象シート).Select
For i = 0 To Range(範囲終点).Column
    For x = 0 To Range(範囲終点).Row
        If Range(範囲始点).Offset(x, i).NoteText <> "" Then
            With Range(範囲始点)
            Sheets(コメント貼り付け対象).Range("A1").Offset(j, 0) = .Offset(x, i).NoteText
            Sheets(コメント貼り付け対象).Range("A1").Offset(j, 1) = .Offset(x, i).Address
            End With
            j = j + 1
        End If
    Next x
Next i
Application.ScreenUpdating = True
Sheets(コメント貼り付け対象).Select

End Sub

Comments

[退会済みユーザー]

すばらしいです。
ありがとうございます。