人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excel2003のマクロに関する質問です。

条件に合った複数行を全てコピーし、別のシートに貼り付けようと思っていろいろと探していたら、
question:1183079896を見つけました。
ここに載っているマクロを利用してみましたが、貼り付けられずに最終行まで行って終わるという状態になってしまいます。コピーはされているようなのですが、1行のみでした。

マクロをよく分かっていないために失敗したのだとは思います。
どうすれば「複数行まとめてコピーして、まとめて貼り付け」の流れが完成するのでしょうか。
また、自分でカスタマイズする際にはどこに気をつければよいでしょうか。

●質問者: ysoct22
●カテゴリ:コンピュータ インターネット
✍キーワード:question: カスタマイズ コピー マクロ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●35ポイント

せっかくなので 前回の不具合も修正して 回答します。

>ひとつのマクロで「Aはシート1、Bはシート2…」なんてできればすごいですが、どうなんでしょう。

Aだったら シート2

Bだったら シート3に複写するようにしました。

Call copysub("A", "Sheet2")

の部分の引数を 変更すればいいだけです。

Sub main()

Call copysub("A", "Sheet2")

Call copysub("B", "Sheet3")

End Sub

Sub copysub(a As String, s As String)

On Error GoTo ending

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(s).Select

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

p = 0

If Sheets(s).Range("A1") <> "" Then

If Sheets(s).Range("A2") = "" Then

Sheets(s).Range("A2").Select

Else

Selection.End(xlDown).Select

p = 1

End If

End If

If Selection.Row = 65536 Then

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

End

End If

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

ActiveSheet.Paste

Sheets("Sheet1").Select

GoTo start

ending:

End Sub

◎質問者からの返答

回答ありがとうございます。

シート名と検索語をいじればいいだけだと思うのですが、どうもうまくいかないようです。

question:1183079896の方は大丈夫だったようですが…。

原因を突き止められずすみません。


2 ● Mook
●35ポイント

taknt さんが回答されているので、同じような内容だとは思いますが、複数後の検索に対応してみました。

★の部分を希望の環境に合わせてください。

1枚目のシートを検索し、結果を検索語の名前のシートにコピーします。

Option Explicit

Const searchRange = "A:D" '--- ★検索元 検索範囲

Sub main()
 Dim searchWord As Variant
 For Each searchWord In Array("ABC", "DEF", "GHI") '--- ★検索する言葉をここで定義
 searchAndCopy CStr(searchWord)
 Next
End Sub

'------------------------------------------
' * 先頭シートから 引数で渡された検索語をコピーする
' * 結果は検索語と同じシート名にする
' * このため、シート名に使えない言葉は検索語とするとエラーになります。
'------------------------------------------
Sub searchAndCopy(sWord As String)
'------------------------------------------
 Dim srcWS As Worksheet
 Set srcWS = Worksheets(1)

 Dim dstWS As Worksheet
 On Error Resume Next
 Set dstWS = Worksheets(sWord)
 On Error GoTo 0
 If dstWS Is Nothing Then
 On Error Resume Next
 Set dstWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
 On Error GoTo 0
 If dstWS Is Nothing Then
 MsgBox "シート【" & sWord & "】が作成できません"
 Exit Sub
 End If
 dstWS.Name = sWord
 End If

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

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

 '--- 検索先シートの serachRange で serachWord を検索
 With srcWS.Range(searchRange)
 Set resRng = .Find(what:=sWord, lookat:=xlPart)
 If resRng Is Nothing Then
 dstWS.Range("A1").Value = "コピーする行がありませんでした。"
 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
◎質問者からの返答

回答ありがとうございます。

こちらはきれいに動きました。挙動も想定していた通りで、僕の伝わりにくい表現を汲み取っていただいてありがとうございました。

もっとマクロ勉強しよう…。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ