|
▼にしもり さん:
こんな感じですか?
Sub TESTf()
Dim varFnm As Variant
Dim wb As Workbook
Dim rng As Range
Dim ws As Worksheet
Dim shtName As String
varFnm = Application.GetOpenFilename("Excel (*.xls), *.xls")
If varFnm = False Then Exit Sub
Set wb = Workbooks.Open(varFnm)
' とりあえず一番左にシートを追加
Set ws = wb.Worksheets.Add(Before:=wb.Worksheets(1))
' 2番目になったけど本当は1番目のシート
With wb.Worksheets(2)
shtName = .Name
Application.DisplayAlerts = False
.AutoFilterMode = False
With .Range("A1").CurrentRegion
.AutoFilter Field:=19, Criteria1:="=*協力*", _
Operator:=xlAnd, Criteria2:="<>*お断り*"
Set rng = .SpecialCells(xlCellTypeVisible)
' 行数が2行以上(1行面はタイトル)の時
If rng.Rows.Count > 1 _
Or rng.Areas.Count > 1 Then
rng.Copy ws.Range("A1")
'該当のシートを削除
wb.Worksheets(2).Delete
' 追加したシートをReName
ws.Name = shtName
Else
' 無かったらファイルを削除
MsgBox "None Data"
Application.DisplayAlerts = False
wb.Close False
' Application.Wait Now + TimeValue("0:00:01")
Kill varFnm
End If
End With
Application.DisplayAlerts = True
End With
End Sub
|
|