• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:エクセルのマクロ(値を検索して別シートにコピー))

エクセルマクロでセルを検索してコピーする方法

このQ&Aのポイント
  • エクセルのマクロを使用して、特定の値を検索して別のシートにコピーする方法をご教示いただけますか?
  • マクロを使用して、アクティブセルの右に5つのセルをコピーし、下に1つのセルを起点として下方向に6セル分をコピーする方法を教えてください。
  • アクティブセルの値と同じ値のセルを別のシートで検索し、該当セルの右に2つ分のセルに行列を入れ替えて値のみをペーストする方法を教えてください。同じ日付が複数ある場合はメッセージを表示します。

質問者が選んだベストアンサー

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率66% (1715/2585)
回答No.3

No.2の追加です Dim fRng As Range を削除して Dim c As Range を追加してください。 また、 If IsDate(c.Value) = True Then はいらないと思いますので(テスト時のものが残ってました) For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)) If IsDate(c.Value) = True Then If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If End If Next を以下に変更してください。 For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)) If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If Next また、日付として同じでも見た目が同じもの以外は別物とする場合 Dim cnt As Long を追加して If WorksheetFunction.CountIf(Ws2.Range("A:A"), Selection.Value) > 1 Then MsgBox "同じ日付が複数あります", vbInformation Set Ws1 = Nothing Set Ws2 = Nothing Exit Sub End If を以下に変更して For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)) If c.Text = Selection.Text Then cnt = cnt + 1 If cnt > 1 Then MsgBox "同じ日付が複数あります", vbInformation Set Ws1 = Nothing Set Ws2 = Nothing Exit Sub End If End If Next その下にある If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If を以下に変更してください。 If c.Text = Selection.Text Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If

すると、全ての回答が全文表示されます。

その他の回答 (4)

  • kkkkkm
  • ベストアンサー率66% (1715/2585)
回答No.5

> 数値を昇順でソートしてからコピーするにはどのような処理を加えればよいでしょうか?(コピーしてからソートでも手間が少ないほうで結構です) 元のSheet1のデータをソートする場合。 最後の方に Tmp = Selection.Offset(1, 5).Resize(6, 1).Value というところがありますので その前にソートのコードを追加します。 ↓追加 Selection.Offset(1, 5).Resize(6, 1).Sort _ Key1:=Selection.Offset(1, 5), Order1:=xlAscending ↑追加ここまで ↓既存のコード Tmp = Selection.Offset(1, 5).Resize(6, 1).Value 転記後のSheet2のデータをソートする場合。 上記コードの下にある If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If の部分を以下に変更してください。 If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) '↓追加 c.Offset(0, 2).Resize(1, 6).Sort _ Key1:=c.Offset(0, 2), Order1:=xlAscending, Orientation:=xlLeftToRight '↑追加ここまで Exit Sub End If

KIKAIDER01
質問者

お礼

バッチリでした。重ね重ねのご教示ありがとうございました。

すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率66% (1715/2585)
回答No.4

No.2の訂正 Findだと同じ形式じゃないと駄目みたいですね。 は Findだと(種類:*2012/3/14)以外だと駄目だったり(種類:*2012年3月14日)の場合いけたり駄目だったりで不安定な感じです。

KIKAIDER01
質問者

お礼

ありがとうございます。私の仕様にいろんなメッセージを追加していただき、何が原因で正しく動作しないのか一目瞭然です。素晴らしいです。

KIKAIDER01
質問者

補足

追加質問で恐縮です。1の「アクティブセルの右に5つ、下に1つのセルを起点として下方向に6セル分」の数値を昇順でソートしてからコピーするにはどのような処理を加えればよいでしょうか?(コピーしてからソートでも手間が少ないほうで結構です)

すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率66% (1715/2585)
回答No.2

> 日付の表示形式の分類を「日付(種類:*2012/3/14)」にするとうまくいきますが、「日付(種類:2012/3/14)」やユーザー定義の「YY/MM/DD」にすると、「該当するデータがありません」というメッセージが出ます。 Findだと同じ形式じゃないと駄目みたいですね。 Findをやめて 'Set fRng = Ws2.Range("A:A").Find(What:=Selection.Text) 'If Not fRng Is Nothing Then ' fRng.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) 'Else ' MsgBox "該当するデータがありません", vbInformation 'End If の部分を For Each c In Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)) If IsDate(c.Value) = True Then If c.Value = Selection.Value Then c.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Exit Sub End If End If Next MsgBox "該当するデータがありません", vbInformation に変更してみてください。 形式に関わらず以下の場合でも同じ日と認識すると思います。 2022/1/10を 形式で以下のようにしたもの 22/1/10 2022年1月10日 2022年1月 1月10日

すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率66% (1715/2585)
回答No.1

以下で試してみてください。 Sub Test() Dim Tmp As Variant Dim Ws1 As Worksheet, Ws2 As Worksheet Dim fRng As Range Set Ws1 = Sheets("Sheet1") If ActiveSheet.Name <> Ws1.Name Then MsgBox Ws1.Name & "以外を選択して実行できません", vbInformation Set Ws1 = Nothing Exit Sub End If If Selection.Count > 1 Then MsgBox "複数のセルを選択して実行できません", vbInformation Set Ws1 = Nothing Exit Sub End If If Selection.Value = "" Then MsgBox "セルに値がありません", vbInformation Set Ws1 = Nothing Exit Sub End If Set Ws2 = Sheets("Sheet2") If WorksheetFunction.CountIf(Ws2.Range("A:A"), Selection.Value) > 1 Then MsgBox "同じ日付が複数あります", vbInformation Set Ws1 = Nothing Set Ws2 = Nothing Exit Sub End If Tmp = Selection.Offset(1, 5).Resize(6, 1).Value Set fRng = Ws2.Range("A:A").Find(What:=Selection.Value, LookIn:=xlValues) If Not fRng Is Nothing Then fRng.Offset(0, 2).Resize(1, 6).Value = WorksheetFunction.Transpose(Tmp) Else MsgBox "該当するデータがありません", vbInformation End If Set Ws1 = Nothing Set Ws2 = Nothing End Sub

KIKAIDER01
質問者

補足

ご教示ありがとうございます。追加の質問があります。私の環境(Windows11)では日付の表示形式の分類を「日付(種類:*2012/3/14)」にするとうまくいきますが、「日付(種類:2012/3/14)」やユーザー定義の「YY/MM/DD」にすると、「該当するデータがありません」というメッセージが出ます。この点に関して詳解していただけると幸いです。

すると、全ての回答が全文表示されます。

関連するQ&A

専門家に質問してみよう