エクセルのマクロで質問です。


基本的なマクロはわかるのですが

シート1の特定行に「ABC」という文字が含まれていたら
シート2にその行をコピーするという事がしたいとおもっております。

シート1は成績
シート2は合否

シート1の成績で合格とかかれている人の行を
シート2に書き出すといったイメージです。

これがマクロで出来るのかどうかは不明ですが
方法があれば教えていただければと思います。

回答の条件
  • 1人3回まで
  • 登録:2007/06/29 10:18:17
  • 終了:2007/06/29 14:46:00

回答(3件)

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982007/06/29 10:32:13

ポイント27pt

Sub Macro1()

'

' Macro1 Macro

'

Sheets("Sheet1").Select

Sheets("Sheet1").Range("A1").Select

Sheets("Sheet1").Cells.Find(What:="ABC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _

xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

, MatchByte:=False, SearchFormat:=False).Activate

Rows(Selection.Row & ":" & Selection.Row).Copy

Sheets("Sheet2").Select

Sheets("Sheet2").Range("A1").Select

Selection.End(xlDown).Select

If Selection.Row = 65536 Then

MsgBox "貼り付けができません。"

End

End If

Cells(Selection.Row + 1, 1).Select

ActiveSheet.Paste

End Sub

こんな感じでいかがでしょうか?

id:quocard

ありがとうございます。

こんなに早くくるなんておもってなかったです。

参考にさせていただきます。

2007/06/29 12:17:12
id:taknt No.2

きゃづみぃ回答回数13538ベストアンサー獲得回数11982007/06/29 10:47:50

ポイント27pt

Sub Macro1()

'

' Macro1 Macro

'

On Error GoTo ending

a = "ABC" '検索キーワード

b = 0

Sheets("Sheet1").Select

Sheets("Sheet1").Range("A1").Select

start:

Sheets("Sheet1").Cells.Find(What:=a, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _

xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

, MatchByte:=False, SearchFormat:=False).Activate

If b > Selection.Row Then GoTo ending

b = Selection.Row

Rows(b & ":" & b).Copy

b = b + 1

Cells(b, 1).Select

Sheets("Sheet2").Select

Sheets("Sheet2").Range("A1").Select

Selection.End(xlDown).Select

If Selection.Row = 65536 Then

MsgBox "貼り付けができません。"

End

End If

Cells(Selection.Row + 1, 1).Select

ActiveSheet.Paste

Sheets("Sheet1").Select

GoTo start

ending:

End Sub



検索箇所が複数あるシートに対応にしました。

id:quocard

複数箇所にまで対応していただきありがとうございます。

こちらも参考にさせていただきます。

2007/06/29 13:48:07
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912007/06/29 11:47:32

ポイント26pt

マクロを複数回実行した場合、該当行が既に合否シートにあるかどうかを判断するのが難しかったので、毎回コピー先シートの2行目以降をクリアしてから

新たにコピーする処理になっています。

先頭の部分を実際に使用する内容に変えて実行してみてください。

Option Explicit
Const srcWSName = "成績"  '--- 検索元シート名
Const dstWSName = "合否"  '--- コピー先シート名

Const searchRange = "B:D"  '--- 検索元 検索範囲
Const searchWord = "ABC"  '--- 検索元 検索文字列

'------------------------------------------
Sub searchAndCopy()
'------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = Worksheets(srcWSName)
    If srcWS Is Nothing Then
        MsgBox srcWSName & "がありません"
    End If

    Dim dstWS As Worksheet
    Set dstWS = Worksheets(dstWSName)
    If dstWS Is Nothing Then
        MsgBox dstWSName & "がありません"
    End If

    Dim resRng As Range
    Dim fstRng As Range
    Dim dstLine As Long

    '--- 書き込み先の2行目から書き出し:最初に2行目以降をクリア
    dstLine = 2
    dstWS.Rows(dstLine & ":" & dstWS.Range("A" & dstWS.Rows.Count).End(xlUp).Row).Clear

    '--- 検索先シートの serachRange で serachWord を検索
    With srcWS.Range(searchRange)
        Set resRng = .Find(what:=searchWord, lookat:=xlPart)
        If resRng Is Nothing Then
            MsgBox "コピーする行がありませんでした。"
            Exit Sub
        End If
        Set fstRng = resRng
        Do
            '--- 見つかったら書き込み先のシートにコピー
            resRng.EntireRow.Copy Destination:=dstWS.Rows(dstLine)
            dstLine = dstLine + 1
            Set resRng = .FindNext(resRng)
        Loop While resRng.Address <> fstRng.Address
    End With
End Sub
id:quocard

ありがとうございます。

こちら変数で指定しやすいようにしてくださり

とても感謝しております。

こういったものを作れるようにがんばりたいと思います。

2007/06/29 13:48:59

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません