| |
コードの記述
まず、シート上のコントロールをクリックしてできあがるシートモジュール上
に必要なコードを書くことからはじめてもいいのですが、以下にコードを
貼り付けますのでそれを指定のモジュールにコピペするほうが早いですね。
なお、FileSystemObjectを使用しますのでMiscrosoft Scripting Runtime に
参照設定をしておいてください。
【ワークブックモジュール】
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If flag正常終了 = False Then
MsgBox "終了時は必ず終了ボタンを押してください"
Cancel = True
Else
If Workbooks.Count = 1 Then Application.Quit
End If
End Sub
Private Sub Workbook_Open()
一覧作成
End Sub
【シートモジュール】
Option Explicit
Private Sub btn_20_Click()
age絞込み 20
End Sub
Private Sub btn_30_Click()
age絞込み 30
End Sub
Private Sub btn_40_Click()
age絞込み 40
End Sub
Private Sub btn_AllAge_Click()
age絞込み 99
End Sub
Private Sub btn_AllJob_Click()
job絞込み 99
End Sub
Private Sub btn_SE_Click()
job絞込み "SE"
End Sub
Private Sub btn_営業_Click()
job絞込み "営業"
End Sub
Private Sub btn_事務_Click()
job絞込み "事務"
End Sub
Private Sub btn_終了_Click()
終了
End Sub
【標準モジュール】
Option Explicit
'【参照設定】 Microsoft Scripting Runtime (FileSystemObject使用)
Public flag正常終了 As Boolean
Const myFolder = "c:\Documents and Settings\user\My Documents" '<==抽出フォルダを規定
Const myExt = "xls" '<==2003
Const myCat=12 '<==2003
Sub 一覧作成()
Dim myLine As Long
Dim wkAge
Dim wkJob
Dim itsMe As String
Dim myFSO As Scripting.FileSystemObject
Dim myBook As Scripting.File
Dim GDOFolder As Object
Dim myCategory As String
Dim aaa
Set myFSO = New Scripting.FileSystemObject
Set GDOFolder = CreateObject("Shell.Application").Namespace(myFolder)
itsMe = ThisWorkbook.Name
With ActiveSheet
myLine = 3
For Each myBook In myFSO.GetFolder(ThisWorkbook.Path).Files
If LCase(myFSO.GetExtensionName(myBook.Name)) = myExt And _
myBook.Name <> itsMe Then
.Hyperlinks.Add Anchor:=.Cells(myLine, 1), _
Address:=myFolder & "\" & myBook.Name, _
TextToDisplay:=myBook.Name
wkAge = ""
wkJob = ""
myCategory = GDOFolder.GetDetailsOf(GDOFolder.ParseName(myBook.Name), myCat)
If myCategory <> "" Then
aaa = Split(myCategory, "/")
wkAge = aaa(0)
If UBound(aaa) >= 1 Then wkJob = aaa(1)
End If
.Cells(myLine, 2).Value = wkAge
.Cells(myLine, 3).Value = wkJob
myLine = myLine + 1
End If
Next
.Range("A2").CurrentRegion.AutoFilter
End With
Set myFSO = Nothing
End Sub
Sub 終了()
flag正常終了 = True
ThisWorkbook.Close savechanges:=False
End Sub
Sub age絞込み(btnVal)
If btnVal = 99 Then
ActiveSheet.Range("A2").CurrentRegion.AutoFilter field:=2
Else
ActiveSheet.Range("A2").CurrentRegion.AutoFilter field:=2, Criteria1:=btnVal
End If
End Sub
Sub job絞込み(btnVal)
If btnVal = 99 Then
ActiveSheet.Range("A2").CurrentRegion.AutoFilter field:=3
Else
ActiveSheet.Range("A2").CurrentRegion.AutoFilter field:=3, Criteria1:=btnVal
End If
End Sub
|
|
［名前なし］
- 10/1/5(火) 18:08 -
