Excelシート名を得る
質問者さんには不評だったものもありますが････ （広告表示も間近なので）
CreateObject("Excel.Application") してからファイルをオープンして･･･
って例題もいっぱいあるし･･･似たようなものも過去記事にあるし･･･で
不慣れな以下２つを記述しておこうかと････
・GetObject を使って
・ADODB の OpenSchema を使って
なお、これらの方法は Runtime 環境でもいけると思います。
ただし難点が･･･ 確認した環境は、Vista+2007 なのですが、
OpenSchema でやった場合、確認していた拡張子が xlsm ファイルでしたけど･･･
Excel ファイルの更新日時が変わっちゃうんですね･･･実行した時刻に････
Excel ファイルの更新日時を見ながら何かしている状況では使えないかな？
他の拡張子ではどうなるんだろう？？
ただね･･･ OpenSchema の方が速いんだよね･･･ GetObject より･･･
また、何らかのエラーがあっても Excel がゾンビっぽくならないし･･･
・GetObject を使って
関数を作ってみました
GetExcelSheet に、Excelファイルのフルパスを与えると
シート名の配列が Variant で得られます。
内部でエラーがあったら、最後のエラー番号を返します。
内部の動きとして、GetObject で対象の Excel ファイルを開きます。
GetObject で初めて開かれた場合、そのファイルの Visible は False
False なら後始末としてそのファイルを閉じ、
結果 Excel で開いているファイルが無ければ、Excel を終了します。
つまり、既に開いていたものについては閉じる事はしません。
この関数の使い方は、後半の Samp1 を例としてください。
Public Function GetExcelSheet(sPath As String) As Variant
Dim oApp As Object, oBook As Object
Dim vA() As Variant, v As Variant
Dim i As Long
On Error Resume Next
i = 0
Set oBook = GetObject(sPath)
If (Not oBook Is Nothing) Then
For Each v In oBook.WorkSheets
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next
Set oApp = oBook.Application
For Each v In oApp.Windows
If (v.Caption = oBook.Name) Then
If (Not v.Visible) Then
oBook.Close SaveChanges:=False
End If
Exit For
End If
Next
Set oBook = Nothing
If (oApp.Workbooks.Count = 0) Then oApp.Quit
Set oApp = Nothing
End If
GetExcelSheet = vA
If (Err <> 0) Then GetExcelSheet = Err.Number
End Function
Public Sub Samp1()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
Dim oApp As Object, oBook As Object
Dim vA() As Variant, v As Variant
Dim i As Long
On Error Resume Next
i = 0
Set oBook = GetObject(sPath)
If (Not oBook Is Nothing) Then
For Each v In oBook.WorkSheets
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next
Set oApp = oBook.Application
For Each v In oApp.Windows
If (v.Caption = oBook.Name) Then
If (Not v.Visible) Then
oBook.Close SaveChanges:=False
End If
Exit For
End If
Next
Set oBook = Nothing
If (oApp.Workbooks.Count = 0) Then oApp.Quit
Set oApp = Nothing
End If
GetExcelSheet = vA
If (Err <> 0) Then GetExcelSheet = Err.Number
End Function
Public Sub Samp1()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
上記記述の中で
For Each v In oApp.Windows
If (v.Caption = oBook.Name) Then
If (Not v.Visible) Then
oBook.Close SaveChanges:=False
End If
Exit For
End If
Next
この部分での、Visible 判別は以下のようにしても良いみたいですねIf (v.Caption = oBook.Name) Then
If (Not v.Visible) Then
oBook.Close SaveChanges:=False
End If
Exit For
End If
Next
If (Not oBook.Windows(1).Visible) Then
とか If (Not oApp.Windows(oBook.Name).Visible) Then
う～ん。いろんなところから･･･色々辿れますね･･･ どれが良いのだろうか･･･？
・ADODB の OpenSchema を使って
不評そうだった OpenSchema を使ったものになります
関数名はチョッと変えていますが、使い方は一緒です。
Public Function GetExcelSheet2(sPath As String) As Variant
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim vA() As Variant
Dim i As Long
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=" & sPath & ";" _
& "Extended Properties='Excel 12.0'"
i = 0
Set rs = cn.OpenSchema(adSchemaTables)
While (Not rs.EOF)
ReDim Preserve vA(i)
vA(i) = Left(rs("TABLE_NAME"), Len(rs("TABLE_NAME")) - 1)
i = i + 1
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
cn.Close
GetExcelSheet2 = vA
If (Err <> 0) Then GetExcelSheet2 = Err.Number
End Function
Public Sub Samp2()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet2(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim vA() As Variant
Dim i As Long
On Error Resume Next
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=" & sPath & ";" _
& "Extended Properties='Excel 12.0'"
i = 0
Set rs = cn.OpenSchema(adSchemaTables)
While (Not rs.EOF)
ReDim Preserve vA(i)
vA(i) = Left(rs("TABLE_NAME"), Len(rs("TABLE_NAME")) - 1)
i = i + 1
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
cn.Close
GetExcelSheet2 = vA
If (Err <> 0) Then GetExcelSheet2 = Err.Number
End Function
Public Sub Samp2()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet2(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
rs("TABLE_NAME") では、シート名 + $ の文字列が得られるので、
$ を判別せずに、$ を除いた左から切り出す･･･ に特化してみました。
冒頭でも言っていましたが、この方法では、確認していた拡張子が xlsm ファイルでしたけど･･･
Excel ファイルの更新日時が変わっちゃうんですね･･･実行した時刻に････
Excel ファイルの更新日時を見ながら何かしている状況では使えないかな？
他の拡張子ではどうなるんだろう？？
上記は Vista+2007 で確認した時の内容になってます。
2000 / 2003 であれば以下２か所、必要に応じて変更すれば良さそうです
Microsoft.ACE.OLEDB.12.0 → Microsoft.Jet.OLEDB.4.0
Excel 12.0 → Excel 8.0
Excel 12.0 → Excel 8.0
【追記】3/7
以下部分を
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=" & sPath & ";" _
& "Extended Properties='Excel 12.0'"
以下に変更すると、更新日時は変わらない様です& "Data Source=" & sPath & ";" _
& "Extended Properties='Excel 12.0'"
cn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "DBQ=" & sPath & ";ReadOnly=1;"
& "DBQ=" & sPath & ";ReadOnly=1;"
・とは言っても CreateObject を使ってみる
GetObject で得られたその環境は、どうなっているんだろうか･･･
こんな面倒な処理を考えなくてすむ分、楽な方法なんですが･･･
Runtime では、CreateObject は使えないそうですね･･･
何故楽か･･･
現状 Excel を使っていようがいまいが、新しい Excel を起動して、
そこには指定したファイルのみを読み込んで･･･
用が済んだら、ファイルを閉じて、Excel を終了して･･･
自分がやっただけの足跡を拭ってくるだけ･･･
雰囲気、以下の様な記述になるんでしょうか･･･
Public Function GetExcelSheet3(sPath As String) As Variant
Dim vA() As Variant, v As Variant
Dim i As Long
On Error Resume Next
i = 0
With CreateObject("Excel.Application")
With .Workbooks.Open(sPath, ReadOnly:=True)
For Each v In .WorkSheets
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next
.Close SaveChanges:=False
End With
.Quit
End With
GetExcelSheet3 = vA
If (Err <> 0) Then GetExcelSheet3 = Err.Number
End Function
Public Sub Samp3()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet3(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
Dim vA() As Variant, v As Variant
Dim i As Long
On Error Resume Next
i = 0
With CreateObject("Excel.Application")
With .Workbooks.Open(sPath, ReadOnly:=True)
For Each v In .WorkSheets
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next
.Close SaveChanges:=False
End With
.Quit
End With
GetExcelSheet3 = vA
If (Err <> 0) Then GetExcelSheet3 = Err.Number
End Function
Public Sub Samp3()
Dim v As Variant
Dim sS As String
Dim i As Long
v = GetExcelSheet3(CurrentProject.Path & "\aaaa.xlsm")
If (IsArray(v)) Then
sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
For i = 0 To UBound(v)
sS = sS & v(i) & vbCrLf
Next
MsgBox sS
End If
End Sub
※ エラーの処理は端折っていますが･･･ 使えなくはない･･･ かな？
今回、サンプルファイルはありません。
- 関連記事
2014/10/26
Category: 関数を作ってみる
TB： -- /
CM： 0
« Excel VBA をやってみた その１３
Excel VBA をやってみた その１２ »
この記事に対するコメント
| h o m e |
