Excel、VBAの質問です。 以下のことをやりたいです。コードを教えてください。 【前提】 she

Excel、VBAの質問です。
以下のことをやりたいです。コードを教えてください。

【前提】
sheet1とsheet2は同じブックにあります。

【必須質問】
sheet1のC列には赤く塗られているセルがあります。その赤く塗られているセルの行にあるA列とB列（←sheet1のです）のデータ内容を抽出して、sheet2のA列とB列にその抽出したsheet1のA列とB列データ貼り付けたいです。
そのsheet2に貼り付けるのは、2行目からにしたいです。

【任意質問】
また、A列、B列、C列以外にも、このような処理を複数実行したいです。どのように書けば一つのボタンクリックで、sheet1の内容をsheet2に複数抽出（先ほどと同じように、例えば、F列の赤く塗られたセルの行のA列とB列の内容を抽出）できるのか教えてほしいです。（こちらはできたらでいいです。最悪上だけで十分です。）

No.1 回答者： Qchan1962 回答日時： 2021/10/19 17:57

こんばんは

どの位の知識が御有りなのか不明ですが、
要件が不明な点を含め、下記のようなもので判りますでしょうか？

【前提】
sheet1とsheet2は同じブックにあります｡
Dim SH1 As Worksheet, SH2 As Worksheet
Set SH1 = Worksheets("Sheet1")
Set SH2 = Worksheets("Sheet2")
sheet1のC列
C列に値がある場合
SH1.Range("C1", SH1.Cells(Rows.Count, "C").End(xlUp))
値がない場合
SH1.Range("C1", SH1.Range("C1").SpecialCells(xlLastCell))
には赤く塗られているセルがあります｡
Dim x As Long
If SH1.Cells(x, "C").Interior.ColorIndex = 3 Then

その赤く塗られているセルの行にある
A列とB列（←sheet1のです）のデータ内容を抽出して、
SH1.Range("A" & x & ":B" & x).Value

sheet2のA列とB列にその抽出したsheet1のA列とB列データ貼り付けたいです｡
Dim n As Long
SH2.Range("A" & n & ":B" & n).Value =
そのsheet2に貼り付けるのは､2行目からにしたいです｡
n = 2
を踏まえて

Sub sample1()
'【前提】
'sheet1とsheet2は同じブックにあります｡
Dim SH1 As Worksheet, SH2 As Worksheet
Set SH1 = Worksheets("Sheet1")
Set SH2 = Worksheets("Sheet2")

Dim r As Range
'そのsheet2に貼り付けるのは､2行目からにしたいです｡
Dim n As Long
n = 2
'sheet1のC列（値がない時）
For Each r In SH1.Range("C1", SH1.Range("C1").SpecialCells(xlLastCell))
'には赤く塗られているセルがあります｡
'その赤く塗られているセルの行にある

If r.Interior.ColorIndex = 3 Then　'赤

'A列とB列（←sheet1のです）のデータ内容を抽出して、
'sheet2のA列とB列にその抽出したsheet1のA列とB列データ貼り付けたいです｡

SH2.Cells(n, 1).Resize(, 2).Value = r.Offset(, -2).Resize(, 2).Value
'上記処理と同じ結果1
'SH2.Range("A" & n & ":B" & n).Value = SH1.Range("A" & r.Row & ":B" & r.Row).Value
'上記処理と同じ結果2
'SH2.Range("A" & n).Value = SH1.Range("A" & r.Row).Value
'SH2.Range("B" & n).Value = SH1.Range("B" & r.Row).Value

n = n + 1
End If
Next
End Sub

>【任意質問】
>一つのボタンクリックで
要件不足でワンクリックとはいかないので、
取得列1，2　と検証　列（セル背景が赤）をUIで取得して処理する
サンプルです。適時列番号の取得方法を変えれば、使えるかな？？

Sub sample2()
Dim SH1 As Worksheet, SH2 As Worksheet
Dim inC1 As Integer, inC2 As Integer, cmprC As Integer
Dim str1 As String
Set SH1 = Worksheets("Sheet1")
Set SH2 = Worksheets("Sheet2")
SH1.Activate

On Error Resume Next
str1 = "抽出列1"
inC1 = keyRng(str1).Column
If inC1 = 0 Then Exit Sub
str1 = "抽出列2"
inC2 = keyRng(str1).Column
If inC2 = 0 Then Exit Sub
str1 = "検査列"
cmprC = keyRng(str1).Column
If cmprC = 0 Then Exit Sub

Dim r As Range
Dim n As Long
n = 2
With SH1
For Each r In .Range(.Cells(1, cmprC), .Cells(1, cmprC).SpecialCells(xlLastCell))
If r.Interior.ColorIndex = 3 Then
SH2.Cells(n, "A").Value = .Cells(r.Row, inC1).Value
SH2.Cells(n, "B").Value = .Cells(r.Row, inC2).Value
n = n + 1
End If
Next
End With
End Sub

Public Function keyRng(str1 As String) As Range
in1:
On Error Resume Next
Set keyRng = Application.InputBox( _
prompt:="マウスで　" & str1 & "　を選択してください", _
Title:="対象の列を選択", _
Default:=" 列　又は、列に含まれるセルを選択", _
Type:=8)
If Err.Number <> 0 Then
Set keyRng = Nothing
Err.Number = 0
Exit Function
End If
If keyRng.Columns.Count > 1 Then
MsgBox ("１列を再選択してください")
GoTo in1
End If
End Function

要件設定をしてやりたい事を書いても作成依頼と変わらないので
なかなか、回答はされないと思います
最低でも上記要件などと共に自身で書いたコードや躓いている所、
エラー内容などを示した方が良いと思います。

このような、カテゴリーの質問の場合
貴方が回答者側であっても同様に、質問者自身で行っている事が見えなければ、色々な意味で回答が難しいですよね。多分、、

よって、この回答が望む結果になるのかはわかりません。