| |
▼にしもり さん：
こんな感じですか？
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))
' ２番目になったけど本当は１番目のシート
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)
' 行数が２行以上（１行面はタイトル）の時
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
