教えて! goo のコンテンツに対する取り組みについて

excel2010 マクロで下記のようなことをしたいのですが
どのようにしたら良いか教えていただけないでしょうか?

①sheet1のA1を検索用の欄とする
②sheet2・sheet3・sheet4にはそれぞれデータを入力しておく
(A列~H列
まで使用し、行数は多くても500程度)
③sheet1のA1に検索したい単語を入力することで、sheet2・sheet3・sheet4全てのA列を検索する
④一致(部分一致)したら、その行をsheet1の10行目以降にコピーする
なお複数ヒットすると思われるため、複数ヒットした場合には行を追加しながらコピーしたいです。

マクロでは無理なのでしょうか?
どのように書いたらよいか、参考になるHPでも助かりますので、教えていただきたく
よろしくお願いします。

gooドクター

A 回答 (2件)

こんなのどうでしょうか。


実行後は戻せませんので、元データはバックアップのうえ、お試しください。

検索ワードは、Sheet1のA1セルとしています。

-------------------------------------------------------------------------
Sub AAA()
Dim r As Long, k As Integer
Dim Ws1 As Worksheet
Dim Moji As String, Rng As Range, Lstrow As Long

Set Ws1 = Worksheets(1)
With Ws1
.Range(.Rows(10), .Rows(Rows.Count)).ClearContents
End With

Moji = Ws1.Cells(1, 1).Value

For k = 2 To 4
r = 2
With Worksheets(k)
Do While .Cells(r, 1).Value <> ""
If InStr(.Cells(r, 1), Moji) <> 0 Then
Set Rng = .Range(.Cells(r, 1), .Cells(r, 8))
Rng.Copy

Lstrow = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Lstrow < 10 Then Lstrow = 10
Ws1.Cells(Lstrow, 1).PasteSpecial Paste:=xlPasteAll
End If

r = r + 1
Loop
End With
Next k
Ws1.Cells(1, 1).Select
Application.CutCopyMode = False

Set Rng = Nothing
Set Ws1 = Nothing

MsgBox "End."


End Sub

----------------------------------------------------------------------
    • good
    • 1
この回答へのお礼

助かりました

ありがとうございます!
できました!
こちらを参考にさせて頂いて、いろいろ調整してみます!

お礼日時:2015/08/24 10:25

こんばんは!



Sheet2~Sheet4の1行目は項目行で、データは2行目以降にあるという前提です。

まず↓のコードをSheet1のシートモジュールにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long
With Target
If .Address = "$A$1" Then
'▼9行目が項目行になっていない場合、ストッパーの役目(念のため)
If .Value <> "" Then
If Range("A9") = "" Then
Range("A9") = "ダミー"
End If
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 9 Then
Range(Cells(10, "A"), Cells(lastRow, "H")).Clear
End If
Call Sample1
End If
End If
End With
End Sub

次に↓のコードを標準モジュールにしてください。

Sub Sample1()
Dim k As Long, lastRow As Long, wS As Worksheet
With Worksheets("Sheet1")
For k = 2 To 4 '←Sheet2~Sheet4
Set wS = Worksheets(k)
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
wS.Range("A1").AutoFilter field:=1, Criteria1:="*" & .Range("A1") & "*"
If wS.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "H")).SpecialCells(xlCellTypeVisible).Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
wS.AutoFilterMode = False
Next k
If .Range("A9") = "ダミー" Then
.Range("A9").ClearContents
End If
End With
End Sub

※ Sheet1のA1セルにデータを入力してみてください。
※ A1セル変更のたびにマクロが実行されます。m(_ _)m
    • good
    • 0
この回答へのお礼

ありがとう

ありがとうございます!
こういう設定方法もあるんですね。
勉強のみちのりはまだまだ続くなぁ。
参考にさせて頂いて、頑張ります!

お礼日時:2015/08/24 10:27

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

このカテゴリの人気Q&Aランキング