|
▼きくと さん:
>ありがとうございます。行の選択が出来ました。
>これを別ブックにコピーするのが難航してますが頑張ります。
参考まで。
Sub Try1plus()
Dim Rng As Range, r As Range
Dim xCol As Long
Dim Find1 As String
Dim Find2 As String
Find1 = "検索1"
Find2 = "検索2"
Set Rng = ActiveSheet.UsedRange 'シート全体
xCol = Rng.Columns.Count
With Rng.Columns(xCol + 1)
.FormulaR1C1 = _
"=IF(AND(COUNTIF(RC1:RC[-1],""" & Find1 _
& """)>0,COUNTIF(RC1:RC[-1],""" & Find2 & """)>0),1,"""")"
On Error Resume Next
Set r = .SpecialCells(xlFormulas, xlNumbers)
On Error GoTo 0
If r Is Nothing Then
MsgBox "検索に一致する行はありません"
Else
r.EntireRow.Select '【該当行の選択】
If MsgBox("これらの行がヒットしました" _
& "別ファイルに出力しますか?" _
, vbOKCancel) _
= vbOK Then
'-----------------------------------------------
Selection.Copy
With Workbooks.Add(6).Worksheets(1)
.Cells(1).PasteSpecial
End With
End If
'-----------------------------------------------
End If
'後始末
.ClearContents
End With
End Sub
|
|