エクセル マクロ 文字の検索と抽出 削除

クセル2010を使っています。

以前回答を頂いたのですが、少し相違点がありましたので再質問させていただきたいと思います。


画像の様に、【Sheet3】のA列～CQ列に　空白・エラー・数値・文字　の入った表があります。

そのL列には、画像の様な形で様々な地域の名前が入っています。


やりたいのは、L列に　検索対象文字、例えば　福岡　か　大阪　が入っていたら、その表ごと抽出し、【Sheet１】の上から順に枠線ごと貼り付けて行きたいと思います。

この時、両方一致ではなく、検索対象の文字列が一つでも含まれていたら抜き出したいと思います。

現在、教えて頂いたコードでは抜き出しはばっちり出来ています。
コード
http://oshiete.goo.ne.jp/qa/8814162.html

その時に　【Sheet3】から抽出した部分は削除し、上に詰めて行きたいと思います。

ちなみに検索対象が、福岡・大阪・名古屋等、増える場合もありますので、増えたとき対応が出来る形が理想です。

ちなみにL列の文字と文字の間は　・　だったり　/　だったりします。

繰返しますが、特定の文字を含む表を元データから抜き出し、抜き出した後に残る表を上に詰めていく形です。

詳しい方、よろしくお願い致します。

No.1 回答者： watabe007 回答日時： 2014/11/15 11:26

Sub Test()

　Dim myAry As Variant, flg As Boolean, v As Variant, i As Long, j As Long

　myAry = Array("福岡", "大阪")
　i = 1
　With Worksheets("Sheet3")
　　Do Until .Cells(i, "L").Value = ""
　　　For Each v In myAry
　　　　flg = False
　　　　If IsError(Application.Match("*" & v & "*", .Cells(i, "L"), 0)) = False Then
　　　　　j = j + 1
　　　　　.Cells(i, "A").Resize(, 95).Copy Worksheets("Sheet1").Cells(j, "A")
　　　　　.Cells(i, "A").Resize(, 95).Delete Shift:=xlUp
　　　　　flg = True
　　　　End If
　　　　If flg = True Then Exit For
　　　Next
　　　If flg = False Then i = i + 1
　　Loop
　End With
End Sub

この回答への補足

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

現在、マクロ実行しているのですが、元データが9万行程度ありまして1時間を越えてしまいました。


PCを1台しか持ってないのですが、やはりこれぐらいの時間は掛かるものなのでしょうか？

よろしくお願い致します。

補足日時：2014/11/15 19:01

No.2 回答者： tom04 回答日時： 2014/11/15 21:21

こんばんは！

前回回答した者です。

前回のコードはそのまま生かして、Sheet3のデータでSheet1に表示されているデータを削除すればよい！というコトですよね？

↓のコードでマクロを試してみてください。
（今回も標準モジュールです）

Sub Sample2()
Dim i As Long, k As Long, myCnt As Long, myMax As Long, lastRow As Long, wS As Worksheet, myAry
Set wS = Worksheets("Sheet1")
myAry = Array("福岡", "大阪") '←ココに増えたデータを追加する★
Application.ScreenUpdating = False
With Worksheets("Sheet3")
For i = 1 To .Cells(Rows.Count, "L").End(xlUp).Row Step 8
myMax = 0
For k = 0 To UBound(myAry)
myMax = WorksheetFunction.Max(myMax, WorksheetFunction.CountIf(.Cells(i, "L").Resize(8), "*" & myAry(k) & "*"))
Next k
If myMax = 8 Then
'▼コピー＆ペーストをカット＆ペーストに変更
Range(.Cells(i, "A"), .Cells(i, "CQ")).Resize(8).Cut wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next i
If WorksheetFunction.CountA(wS.Rows(1)) = 0 Then
wS.Rows(1).Delete
End If
'▼Sheet3の削除
lastRow = .Cells(Rows.Count, "L").End(xlUp).Row
Range(.Cells(1, "A"), .Cells(lastRow, "CQ")).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

これではどうでしょうか？m(_ _)m

No.3 回答者： tom04 回答日時： 2014/11/15 22:22

No.2です。

たびたびごめんなさい。

前回のコードでは他の列に空白セルがある場合、そのセルも削除されてしまいますので
行が合わなくなると思います。

前回のコードは消去して↓のコードに変更してください。

Sub Sample3()
Dim i As Long, k As Long, j As Long, myCnt As Long, myMax As Long
Dim myRng As Range, wS As Worksheet, myAry
Set wS = Worksheets("Sheet1")
myAry = Array("福岡", "大阪") '←ココに増えたデータを追加する★
Application.ScreenUpdating = False
With Worksheets("Sheet3")
For i = 1 To .Cells(Rows.Count, "L").End(xlUp).Row Step 8
myMax = 0
For k = 0 To UBound(myAry)
myMax = WorksheetFunction.Max(myMax, WorksheetFunction.CountIf(.Cells(i, "L").Resize(8), "*" & myAry(k) & "*"))
Next k
If myMax = 8 Then
Set myRng = Range(.Cells(i, "A"), .Cells(i, "CQ")).Resize(8)
Exit For
End If
Next i
If Not myRng Is Nothing Then
For j = i + 8 To .Cells(Rows.Count, "L").End(xlUp).Row Step 8
myMax = 0
For k = 0 To UBound(myAry)
myMax = WorksheetFunction.Max(myMax, WorksheetFunction.CountIf(.Cells(j, "L").Resize(8), "*" & myAry(k) & "*"))
Next k
If myMax = 8 Then
Set myRng = Union(myRng, Range(.Cells(j, "A"), .Cells(j, "CQ")).Resize(8))
End If
Next j
End If
On Error Resume Next '←念のため★
myRng.Copy wS.Range("A1")
myRng.Delete shift:=xlUp
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

これで空白セルがあっても大丈夫だと思います。m(_ _)m

No.4 ベストアンサー 回答者： watabe007 回答日時： 2014/11/15 22:55

>元データが9万行程度ありまして1時間を越えてしまいました。

９万行の移動、行削除を行うのですから、それなりの時間はかかるでしょう
行の削除は行わず配列を使って値の転記だけを行ってみました。
処理時間は劇的に変わったと思いますが・・・
Sub Test3()
　　Dim objRE As Object, myMatches As Object
　　Dim LastRow As Long, i As Long, j As Long, k As Long, m As Long
　　Dim v1(), v2()

　　Set objRE = CreateObject("VBScript.RegExp")
　　objRE.Pattern = "福岡|大阪" '検索文字を|で繋いでください。
　　objRE.Global = True
　　With Worksheets("Sheet3")
　　　　LastRow = .Cells(Rows.Count, "L").End(xlUp).Row
　　　　ReDim v1(1 To LastRow, 1 To 95)
　　　　ReDim v2(1 To LastRow, 1 To 95)
　　　　For i = 1 To LastRow
　　　　　　Set myMatches = objRE.Execute(.Cells(i, "L").Value)
　　　　　　If myMatches.Count > 0 Then
　　　　　　　　j = j + 1
　　　　　　　　For m = 1 To 95
　　　　　　　　　　v1(j, m) = .Cells(i, m).Value
　　　　　　　　Next
　　　　　　Else
　　　　　　　　k = k + 1
　　　　　　　　For m = 1 To 95
　　　　　　　　　　v2(k, m) = .Cells(i, m).Value
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With
　　Worksheets("Sheet1").Range("A1").Resize(LastRow, 95).Value = v1
　　Worksheets("Sheet3").Range("A1").Resize(LastRow, 95).Value = v2
　　Set objRE = Nothing
　　Set myMatches = Nothing
End Sub

この回答への補足

再度の回答を頂き　大変感謝いたします、ありがとうございます。

処理時間も大幅に短縮でき素晴らしいと思いました。


それで一点質問させて頂きたいのですが、画像ではCQ列までの表となっていますが、これをEO列まで拡張するとすれば、単純に　95行(列）　の部分6箇所を145に書き換えれば良いのでしょうか？

重ね重ねお手数をおかけしますが、教えていただけませんでしょうか。

よろしくお願い致します。　m(_ _)m

補足日時：2014/11/16 00:24

No.5 回答者： watabe007 回答日時： 2014/11/16 08:12

>画像ではCQ列までの表となっていますが、これをEO列まで拡張するとすれば、

>単純に　95行(列)の部分6箇所を145に書き換えれば良いのでしょうか？
それで大丈夫です。

この回答へのお礼

再度の回答頂きありがとうございます。

お陰さまで無事目的が果たせました、心よりお礼申し上げます。

ありがとうございました。

お礼日時：2014/11/16 21:15

No.6 回答者： tom04 回答日時： 2014/11/16 09:40

No.2・3です。

たびたびごめんなさい。
今までの方法ではめちゃくちゃ時間がかかってどうしようもありませんね。
汎用性には欠けるかもしれませんが、別の方法です。
今回はループしないでやってみました。
今までのコードはすべて無視して↓のコードにしてみてください。

Sub Sample4()
Dim lastRow As Long, lastCol As Long, wS As Worksheet
Application.ScreenUpdating = False
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
With Worksheets("Sheet3")
.Rows(1).Insert
lastRow = .Cells(Rows.Count, "L").End(xlUp).Row
.Range("A:B").Insert
.Range("A1") = "ダミー"
Range(.Cells(2, "A"), .Cells(lastRow, "A")).Formula = "=MOD(ROW()-2,8)"
'▼ココで「増える対象」の関数を追加する。
Range(.Cells(2, "B"), .Cells(lastRow, "B")).Formula = "=IF(A2=0,IF(OR(COUNTIF(N2:N9,""*福岡*"")=8,COUNTIF(N2:N9,""*大阪*"")=8),1,""""),B1)"
.Range("A1").AutoFilter field:=2, Criteria1:=1
On Error Resume Next
'▼作業用の列をA・B2列挿入しているので、元データが2列右にずれる！
Range(.Cells(2, "C"), .Cells(lastRow, "CS")).SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Sheet1").Range("A1")
.Range("A1").AutoFilter field:=2, Criteria1:=""
Range(.Cells(2, "C"), .Cells(lastRow, "CS")).SpecialCells(xlCellTypeVisible).Copy _
wS.Range("A1")
.AutoFilterMode = False
.Rows(1).Delete
.Range("A:B").Delete
Range(.Cells(1, "A"), .Cells(lastRow, "CQ")).Clear
lastRow = wS.UsedRange.Rows.Count
lastCol = wS.UsedRange.Columns.Count
Range(wS.Cells(1, "A"), wS.Cells(lastRow, lastCol)).Copy .Range("A1")
Application.DisplayAlerts = False
wS.Delete
Application.DisplayAlerts = True
.Activate
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　今回はおそらく1分かからないと思います。

※　「汎用性に欠ける」と書いたのは、「検索対象」が増える場合に
コード内にも記載しているように、ワークシート関数なので
単に「検索対象」だけを追加するのではなく、OR関数そのものを追加しなければなりません。

とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

再度の回答を頂きありがとうございます。

試してみました、かかる時間も1分以内でとても時間の短縮になりました。

お手数を頂き、大変感謝いたします、ありがとうございました。

お礼日時：2014/11/16 22:01