|
▼ponpon さん:
ありがとうございます。早速試してみました。
下記のように少し加えてたのですが、最後にsheet1のA5からの表の
削除がうまくいきません。
特にエラーもでないのですが、なぜでしょうか。
よろしくお願いいたします。
Sub 検索から削除()
Dim dayR As Range
Dim moVa As Variant
Dim dayLo As Long
Dim r As Range
Dim shtName As String
Dim i As Long
With Worksheets("ワード")
moVa = .Range("A2", .Range("A65536").End(xlUp)).Value
End With
With Worksheets("sheet1")
Set dayR = .Range("B5", .Range("B65536").End(xlUp))
dayLo = .Range("B65536").End(xlUp).Row
For i = 1 To UBound(moVa, 1)
For Each r In dayR
If InStr(r.Value, moVa(i, 1)) > 0 Then
r.Offset(0, 26).Value = 1
End If
Next
Next
With Range("AB5:AB" & dayLo)
Application.DisplayAlerts = False
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.DisplayAlerts = True
.Value = ClearContents
End With
End With
MsgBox "現在のシートをコピーします"
ReName:
shtName = Application.InputBox("シート名を入力して下さい。", "シート名入力", Type:=2)
If shtName = "False" Then
MsgBox "キャンセルしました。"
Exit Sub
End If
For i = 1 To Worksheets.Count
If Worksheets(i).Name = shtName Then
MsgBox shtName & " は、既にあります。", vbExclamation, "エラー"
GoTo ReName
End If
Next i
On Error GoTo WrongName
ActiveSheet.Copy after:=Worksheets(3)
ActiveSheet.Name = shtName
On Error GoTo 0
MsgBox "完了"
Exit Sub
WrongName:
MsgBox "シート名に使えない文字が含まれています。", vbExclamation, "エラー"
shtName = Application.InputBox("シート名を入力して下さい。", "シート名入力", Type:=2)
Worksheets("sheet1").Range("A5:E999").Delete
End Sub
|
|