VBAでADOでシート名を取得する場合

　こんにちは
　　VBAでADOでシート名を取得する場合の質問をさせて頂きたいです

　

 FileN = C:\ほげほげ\エクセル.xlsm

 SNo = シートNo ※これが、





Function MyADOExcel666(FileN As String, SNo As Long)

  

    Dim cn     As Object

    Dim rs     As Object

    Dim adoCat As Object

     

    Set cn = CreateObject("ADODB.Connection")

    Set rs = CreateObject("ADODB.Recordset")

    cn.Provider = "Microsoft.ACE.OLEDB.12.0"

     

    cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"

 

    cn.Open FileN

 

    Set adoCat = New ADOX.Catalog

    Set adoCat.ActiveConnection = cn

    

    MyADOExcel666 = adoCat.Tables(SNo).Name

 

'   rs.Close 

'    Set rs = Nothing 

'    cn.Close 

'    Set cn = Nothing 

     

End Function

のようなコードで、一応シート名は取得できるようなのですが、
ワークブックの一番左のシート名の取得
（sheets(0).name　みたいな）
というような、シート名は、どのように取得したら良いのでしょうか？
よろしくお願いします。

　ごめんなさい
>　　sheets(0).name みたいに
 でなくて
　　sheets(1).name みたいに
　でした

　ごめんなさい

　エクセル2016の64bit、win10です

> VBAでADOでシート名を取得する場合の質問をさせて頂きたいです
CreateObject("Excel.Application") では都合が悪いという状況でしょうか。


> ワークブックの一番左のシート名の取得
> （sheets(0).name　みたいな）
Excel のワークシートは 1 から始まるものだったはずでは…?

現状のコードだと、引数の SNo As Long が、そのインデックスにあたると思います。
ただしこちらは 0 から始まる番号です。
また、OLE DB Provider 側の仕様で、シート名の末尾に $ を付けた名前として返却されます。


> Set adoCat = New ADOX.Catalog
ADODB は参照設定なしで動くようにしているのに、
ADOX の方は CreateObject を使わず、参照設定を必須にしている点に違和感があります。

そもそも参照設定しているのなら、 As Object にするのではなく、
それぞれの固有型の変数として宣言した方が良いと思いますよ。


あるいは、ADOX を使わないスタイルもありますね。
(スキーマを取得するという点では同じことですが)

試しに、シート名の配列を返すようにしてみました。
今回は Excel のように 1 から始まる番号で返すようにしています。

Function GetSheetNames(ByVal excelFile As String) As String()

    Dim sheetNames() As String



    Const adUseClient As Long = 3&

    Const adSchemaTables As Long = &H14&

    Dim cn As Object, rs As Object

    Set cn = CreateObject("ADODB.Connection")

    cn.Provider = "Microsoft.ACE.OLEDB.12.0"

    cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"

    cn.Open excelFile

    Set rs = cn.OpenSchema(adSchemaTables)  'ADOX を使わずにスキーマを取得 

    ReDim sheetNames(1 To rs.RecordCount)

    Dim idx As Long

    idx = 0&

    Do Until rs.EOF

        idx = idx + 1&

        sheetNames(idx) = rs.Collect("TABLE_NAME")

        If sheetNames(idx) Like "*$" Then   '末尾の $ を除去 

            sheetNames(idx) = Left(sheetNames(idx), Len(sheetNames(idx)) - 1)

        End If

        rs.MoveNext

    Loop

    rs.Close

    cn.Close

    

    Set GetSheetNames = sheetNames

End Function

　こんばんは、いつもありがとうございます

>CreateObject("Excel.Application") では都合が悪いという状況でしょうか。
いっぱいほぼ一緒の形式のファイルがあり、値もほぼ一緒の位置にあります。
できれば開けずに、値を集約したかったです。

>> ワークブックの一番左のシート名の取得
>> （sheets(0).name　みたいな）
>Excel のワークシートは 1 から始まるものだったはずでは…?
これは、自分でも気づいて修正させていただきました。

>> Set adoCat = New ADOX.Catalog
>ADODB は参照設定なしで動くようにしているのに、
>ADOX の方は CreateObject を使わず、参照設定を必須にしている点に違和感があります。
    Dim adoCat As ADOX.Catalog
   または Set adoCat = CreateObject("ADOX.Catalog")
 　に、修正する形でよろしいでしょうか？

>試しに、シート名の配列を返すようにしてみました。
>今回は Excel のように 1 から始まる番号で返すようにしています。
シート名で並び替え済なのか、エクセルのシート順を変えても順が変わりません。

 シートがA、B、Cという並びでも
 シートがC、A、Bという並びでも
　A
  B
  C
 というように返してくるようでした

 シートがA、B、Cという並びでは
　A
  B
  C
 シートがC、A、Bという並びでは
  C
　A
  B
を返すようにならないでしょうか？

自分のADOXでも、SNoを調節しなくては、目的の値が取得できていません。
あるファイルでは、SNo=1、あるファイルでは、SNo=2というように

>ReDim sheetNames(1 To rs.RecordCount)
が、エラー(値が-1）になり、１００決め打ちでエラー回避してみました。

> できれば開けずに、値を集約したかったです。
ADODB であれ Excel であれ OpenXML であれ ClosedXML であれ、
ファイルを開かないと中身が読み取れないという点は同じことですが、
数式や画像が多い場合は、Excel.Application だと時間がかかってしまうかもしれませんね。


>> ADOX の方は CreateObject を使わず、参照設定を必須にしている点に違和感があります。
> Dim adoCat As ADOX.Catalog
> または Set adoCat = CreateObject("ADOX.Catalog")
> に、修正する形でよろしいでしょうか？
そうですね。
ついでに言えば、「ADODB と ADOX の両方を参照しておく」か、
「いずれも参照設定しない状態」にする方が統一性が取れるでしょう。
（可能なら、参照して使う方法にしておいた方が良いとは思います）


> エクセルのシート順を変えても順が変わりません。
ADOX にしても adSchemaTables にしても、
列挙順については保証の限りでは無い、ということなのでしょう。

手元の環境でも、
　シート順を変更して保存すると列挙順が変化するワークブック
　シート順を変更して保存しても列挙順が変わらないワークブック
と様々です。

検証を重ねていないので、何が影響しているのかまでは特定しておりませんが、
いずれの方法も、「列挙順」に関しては、確実性のある列挙方法とは言い難いです。
Excel.Application 経由で調べる方法と比較すると、
正直、そこまでの厳密性は期待できなさそうですね。

Excel のバイナリーフォーマットは公開されているので、調べようとすれば
Excel.Application を使うよりも早く列挙することができるかもしれませんが、
それだけのために直接バイナリを扱うのは、あまり現実的では無さそうです。

なお、snowmansnow さんの最初のコードにしても私の手法にしても、
ファイルによっては、追加の作業が発生するようです。

手元にあった 3 シート構成のブックが 0～5 の 6 件のデータを返すことがありました。
そのケースでは .Worksheets(1).Name が "実施概要" だったのですが、
　SNo = 0 → "実施概要$"
　SNo = 1 → "実施概要$_xlnm#Print_Area"
といった形式で、の文字列を返してきました。
どうやら印刷範囲設定が、名前の定義として認識されているようですね。

また、.Worksheets(2).Name = "実施概要 (変更前)" に対しては
　SNo = 2 → "'実施概要 (変更前)$'"
　SNo = 3 → "'実施概要 (変更前)$'_xlnm#Print_Area"
のような文字列が返されるケースもありました。
末尾 $ だけでなく、両端シングルクォートも考慮せねばならないようです。


>> ReDim sheetNames(1 To rs.RecordCount)
> が、エラー(値が-1）になり、１００決め打ちで
　Dim cn As ADODB.Connection, rs As ADODB.Recordset
　Set cn = CreateObject("ADODB.Connection")
　cn.CursorLocation = adUseClient
にした場合は正しい件数を返したのに対して
　Dim cn As Object, rs As Object
　Set cn = CreateObject("ADODB.Connection")
　cn.CursorLocation = adUseServer
だと、-1 を返してきました。
どちらの場合も、rs.CursorLocation は adUseServer になりました。

RecordCount に頼るのも不安なので、配列ではなく Dictionary に加えていくか
rs.GetRows で取得した方が安全そうですね。


Print_Area 関連を除去するコードも加えると、こんな感じでどうでしょう。

'シート名の一覧を返す(列挙順は保証できない) 

Function GetSheetNames(ByVal excelFile As String) As String()

    Dim cn As ADODB.Connection, rs As ADODB.Recordset

    Set cn = New ADODB.Connection

    cn.CursorLocation = adUseClient

    cn.Provider = "Microsoft.ACE.OLEDB.12.0"

    cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"

    cn.Open excelFile

    Set rs = cn.OpenSchema(adSchemaTables)

    

    Dim re As VBScript_RegExp_55.RegExp

    Dim ms As VBScript_RegExp_55.MatchCollection, rm As VBScript_RegExp_55.Match

    Set re = New VBScript_RegExp_55.RegExp

    re.Pattern = "^'?(.*)\$'?(#Print_Area|_xlnm#Print_Area)?$"

    Dim dict As Scripting.Dictionary

    Set dict = New Scripting.Dictionary

    Dim tableName As String

    Do Until rs.EOF

        tableName = rs.Collect("TABLE_NAME")

        '各種接尾辞を削ぎ落す 

        Set ms = re.Execute(tableName)

        If ms.Count > 0 Then

            Set rm = ms.Item(0)

            tableName = rm.SubMatches(0)

        Else

            Debug.Print tableName

        End If

        dict(tableName) = CByte(0)

        rs.MoveNext

    Loop

    rs.Close

    cn.Close



    '「内部型式が String なバリアント型の一次元配列」を「文字列型の一次元配列」に変換 

    GetSheetNames = Split(Join(dict.Keys(), vbNullChar), vbNullChar)

End Function

この関数の戻り値は As String() ですが、
これを As Variant() にしても構わなければ、最後の行は
　GetSheetNames = dict.Items()
だけで済みます。

また、名前以外の附帯情報が付いても構わない場合は GetRows を使うのが簡単です。
この場合、MoveNext や Dictionary も不要です。

Set rs = cn.OpenSchema(adSchemaTables)

GetSheetNames = rs.GetRows(-1)  '二次元配列として返却 

rs.Close

cn.Close

このケースでは、戻り値が (列番号, 行番号) 形式の二次元配列となり、
TABLE_NAME は列番号 2 となります。

 こんにちは、魔界の仮面弁士様
　詳しい説明ありがとうございます

>手元の環境でも、
>　シート順を変更して保存すると列挙順が変化するワークブック
>　シート順を変更して保存しても列挙順が変わらないワークブック
>と様々です。
色々調べていただきありがとうございます
>　列挙順が変化するワークブック
だったら良かったのですが、手元では変わりませんでした・・・

>Excel のバイナリーフォーマットは公開されているので、調べようとすれば
>Excel.Application を使うよりも早く列挙することができるかもしれませんが、
>それだけのために直接バイナリを扱うのは、あまり現実的では無さそうです。
zipとかxlmとか、ハードルが高そうでしたので、ダメだと思います。
（i-filterみたいな、table-filterみたいなのがあるといいなぁと思いました・・・）

>なお、snowmansnow さんの最初のコードにしても私の手法にしても、
>ファイルによっては、追加の作業が発生するようです。
ADOXとOpenSchemaで、両方できるようにして頂いたので、
OpenSchemaの勉強もしていきたいと思います。
シート名は、目検で確認してから、データを取得する方法で、いきたいと思います。


正規表現と辞書を使って頂きましたので、
勉強していきたいと思います。
（正規表現は、自分でも使ってみているのですが、１．０と５．５があるのを知りませんでした。
　辞書もまだ敷居が高くて使ってみていなかったです）

諸事情で、数日、追加のお返事、確認しづらくなってしまいますが、
また宜しく御願い致します。
いつも、御教授ありがとうございます。

>>　列挙順が変化するワークブック
> だったら良かったのですが、手元では変わりませんでした・・・
その場合、Excel の Worksheets コレクションでも変化しない状況でしょうか。


> 正規表現は、自分でも使ってみているのですが、１．０と５．５があるのを知りませんでした。
Windows Scripting 5.5 に付随するライブラリですね。
バージョンが 5.5 なのは、2000年7月に公開された
Internet Explorer 5.5 とバージョンを揃えるためでしょう。

1.0 との違いは、SubMatches が使えるかどうかです。
https://qiita.com/Q11Q/items/56db596629a124f94b7e


> 辞書もまだ敷居が高くて使ってみていなかったです
今回 Dictionary を使ったのは、Ｐｒｉｎｔ_Area の有無で結果が変わらないようにするためです。
別案として、Function の戻り値を As VBA.Collection にする方法もあるでしょう。


Dictionary は登録順に列挙されるようですが、削除と追加を繰り返した場合の
列挙順は保証されていません。一方 Collection は列挙順が保証されているのですが、
重複判定などは、Collection よりも Dictionary の方が便利だったりします。

　こんにちは、魔界の仮面弁士様、るきお様
　諸事情で、お返事できず申し訳ございませんでした。

　>>　列挙順が変化するワークブック
　>> だったら良かったのですが、手元では変わりませんでした・・・
  >その場合、Excel の Worksheets コレクションでも変化しない状況でしょうか。
  はい、sheets(1).nameは、変わります。

  >1.0 との違いは、SubMatches が使えるかどうかです。
  .submatches(0)とか使った事がありますので、知らずに5.5を使っていたかもしれません。

 >Dictionary は登録順に列挙されるようですが、削除と追加を繰り返した場合の
 >列挙順は保証されていません。一方 Collection は列挙順が保証されているのですが、 
 >重複判定などは、Collection よりも Dictionary の方が便利だったりします。
 機会がありましたら、使ってみたいです。

  久しぶりにパソコン触れましたので、諸先輩方の例を参考にVB.NETでシート名羅列を作ってみました
　よろしかったら見てやって下さい
　（フォームにマルチラインのテキストボックスとボタン１個配置します）
  

Imports System.IO.Compression

Imports System.Text.RegularExpressions



Public Class Form1



    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim zipFilePath As System.IO.Compression.ZipArchive = ZipFile.OpenRead("C:\Users\Y2\Desktop\excel2.xlsm")

        Dim zipInFile As System.IO.Compression.ZipArchiveEntry = zipFilePath.GetEntry("xl/workbook.xml")

        If zipInFile Is Nothing Then

            MessageBox.Show("workbook.xmlファイルは見つかりませんでした。")

        Else

            Dim sr As New System.IO.StreamReader(zipInFile.Open(),

                                                 System.Text.Encoding.GetEncoding("utf-8"))

            Dim TextBox1Text As String

            While sr.Peek >= 0

                TextBox1Text += sr.ReadLine

            End While

            Dim results As MatchCollection = Regex.Matches(TextBox1Text, "<sheets>.*</sheets>")

            Dim result1 As String

            For Each m As Match In results 

                Dim index As Integer = m.Index 

                Dim value As String = m.Value 

                result1 += value + vbCrLf

            Next

            Dim result2 As MatchCollection = Regex.Matches(result1, "<sheet\s.*?sheetId")

            Dim result3 As String

            For Each m As Match In result2 

                Dim index2 As Integer = m.Index 

                Dim value2 As String = m.Value 

                result3 += value2 + vbCrLf

                Me.TextBox1.Text += Replace(Mid(value2, 14, 100), """ sheetID", "", 1, 100, CompareMethod.Text) + vbCrLf

            Next

            Console.WriteLine(result3)

            If sr IsNot Nothing Then

                sr.Close()

                sr.Dispose()

                sr = Nothing

                GC.Collect()

            End If

        End If

    End Sub

End Class

 

 よろしくお願いします。