■SQL.REQUEST関数

VBAではなく、外部アドインでのワークシート関数の話です。
こちらには『Excel 2002 でのみサポート』とありますが、2000にも元からあったような気がします（？）。
まぁ、別途ダウンロードもできるようになっているのであまり細かい事は言わないようにしよう。

たまに、『他のファイルを参照する時に、セルにファイル名、シート名を入力して、その値を使ったリンク式で参照できないか、ただし、そのファイルは閉じたまま』...という質問を見かけます。
セルの値を変更する事で、簡単に参照先を変更したいという事でしょう。
セル値を参照してというと、INDIRECT関数などですが、これは閉じているファイルは参照できません。
通常はマクロを組み合わせたり、数式自体を置換する事で対応したり、というアドバイスになってしまいますね。
ですが、実用的かどうかはさておき、XLODBC.XLAのSQL.REQUEST関数を使えばできなくもない...というところでしょうか。

一例として、下記のようなコードで使用例を作ってみました。

Sub try()
　　Const wkPath As String = "D:¥"
　　Const wkBook As String = "test.xls"

　　'新規Book作成しダミーデータセット、D:¥test.xlsとして保存後閉じる。
　　With Workbooks.Add(xlWBATWorksheet)
　　　　With .Sheets(1)
　　　　　　.Range("A1:B1").Value = Array("field1", "field2")
　　　　　　.Range("A2:B10").Formula = Array("=ADDRESS(ROW(),COLUMN(),4)", "=ROW()")
　　　　End With
　　　　.SaveAs wkPath & wkBook
　　　　.Close
　　End With
　　'アドインできない場合、手動で。
　　AddIns("ODBC アドイン").Installed = True
　　'ThisWorkbook.Sheets.AddにSQL.REQUEST関数をセット。
　　With ThisWorkbook
　　　　With .Sheets.Add
　　　　　　.Range("A1:F1").Value = Array("path", "book", "sheet", "chk", "sql", "ans")
　　　　　　.Range("A2:D2").Value = Array(wkPath, wkBook, "sheet1", "A2")
　　　　　　.Range("E2").Formula _
　　　　　　　　= "=""SELECT field2 FROM [""&C2&""$] WHERE field1='""&D2&""'"""
　　　　　　.Range("F2").Formula _
　　　　　　　　= "=SQL.REQUEST(""DSN=Excel Files;DBQ=""&A2&B2,,4,E2,FALSE)"
　　　　　　.Columns("A:F").AutoFit
　　　　　　Application.Goto .Range("F2")
　　　　End With
　　End With
End Sub

（Write側ThisWorkbookのシート）


A2:E2までを条件入力エリアとしてます。

書式は SQL.REQUEST(接続コード, 出力セル, ダイアログ表示, ステートメント, 列名表示) で、
[接続コード]……… "DSN=Excel Files;DBQ=" の後にファイルのフルパス名。
[出力セル]…………結果が返されるセルですが、ワークシート関数として使う場合は設定しても無視され、式の入力セルに結果が返るので省略します。
[ダイアログ表示]…例のような関数として使う場合は 4 の『表示しない』にして、設定がおかしかったらエラー値が返るようにしておけばいいでしょう。
[ステートメント]…SQLの構文を記述します。SQLについて学習すると、応用の幅が広がるかもしれません。
[列名表示]…………結果に列名（見出し）を表示させるかどうかです。結果を配列（というかQUERY結果のようなデータ群）として表示させたい場合はTRUEにしたほうが良いかもしれません。

参照先のサンプルは下図のようなデータで、D2セルに入力した値を照合して、そのB列の値を得る、というようなVLOOKUP的な例示にしてみました。

（Read側D:test.xlsのSheet1）

■[Justify メソッド]

『対象セル範囲内の文字列を、そのセル範囲に合わせて割り付けます。』とヘルプにあります。
一般機能で言えば、[編集]-[フィル]-[文字の割付]です。
文章をシートに配置する時に、セル範囲、というかセルの列幅に合わせて（見た目の）行末を揃え、複数行に渡って配置調整してくれる。...というような機能のようです。
テキストボックスを使えばいいのでは？と思うのであまり使った事はないですが、どうなのでしょうね。

実際にはちょっとした制限があり、
・256文字以降は切り捨てられる。
・改行文字が無視される。
・行頭のスペースが無視される。
ようです。

一度このメソッドを使ってレスを入れた事がありますが、その時は上記制限について改行文字の対応しかしていませんでした。なので今回改良版を考えてみました。
経由でもいいのでForms.TextBoxを使うと、改行コードがvbCrLfになるので戻す必要がある時に便利かもしれません。

'UserForm Module
Option Explicit

Private Sub CommandButton1_Click()
　　Dim flg As Boolean
　　Dim chk As Boolean
　　Dim s() As String
　　Dim tmp As String
　　Dim n　 As Long
　　Dim i　 As Long

　　On Error GoTo errHndlr
　　With ActiveSheet
　　　　n = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　If Not IsEmpty(.Cells(n, 1).Value) Then n = n + 1
　　　　Application.DisplayAlerts = False
　　　　s = Split(Me.TextBox1.Text, vbLf)
　　　　For i = 0 To UBound(s)
　　　　　　Do
　　　　　　　　flg = Len(s(i)) > 254
　　　　　　　　'[ 　]内は半角|全角スペース
　　　　　　　　chk = s(i) Like "[ 　]*"
　　　　　　　　If flg Then
　　　　　　　　　　tmp = Mid$(s(i), 255)
　　　　　　　　　　s(i) = Left$(s(i), 254)
　　　　　　　　End If
　　　　　　　　If chk Then s(i) = "''" & s(i)
　　　　　　　　With .Cells(n, 1)
　　　　　　　　　　.Value = s(i)
　　　　　　　　　　.Justify
　　　　　　　　End With
　　　　　　　　If chk Then .Cells(n, 1).Value = Mid$(.Cells(n, 1).Value, 2)
　　　　　　　　n = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　　　　　If flg Then
　　　　　　　　　　s(i) = .Cells(n, 1).Value & tmp
　　　　　　　　Else
　　　　　　　　　　Exit Do
　　　　　　　　End If
　　　　　　Loop
　　　　　　n = n + 1
　　　　Next
　　　　'vbCr消してもいいけど残しておけば戻す時に使えそう。
　　　　'.Columns(1).Replace What:=vbCr, Replacement:="", LookAt:=xlPart
　　End With
　　Me.TextBox1.Text = ""
errHndlr:
　　Application.DisplayAlerts = True
End Sub
'-------------------------------------------------
Private Sub CommandButton2_Click()
　　Dim s As String
　　Dim v

　　With ActiveSheet
　　　　With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = Application.Transpose(.Value)
　　　　　　If Not IsArray(v) Then Exit Sub
　　　　　　.ClearContents
　　　　End With
　　End With
　　s = Join(v, "")
　　Me.TextBox1.Text = s
End Sub

■xlsブックのSheet一覧(ADO)

前回、前フリしましたが(...したっけ？:-)
[ActiveX Data Objects (ADO)]を使ってSheet一覧を取得してみます。
Workbooks.Openメソッドで開いて処理するほうが安定していて確実だと思いますし、後述の理由で、実用的でない方法かもしれません。
『[HOWTO] Visual Basic または VBA から ADO を Excel データで使用する』この記事や
『ADOを使ってExcelのシート名を高速に取得する』このサイトを参考にさせて頂きました。

Sub try()
　　Const adSchemaTables As Long = 20
　　Dim Ado　　As Object
　　Dim AdoRs　As Object
　　Dim Reg　　As Object
　　Dim bkName As String
　　Dim tbName As String
　　Dim fdName As String
　　Dim fn　　 As String
　　Dim re　　 As String
　　Dim i　　　As Long
　　Dim n　　　As Long
　　Dim v(0 To 65535, 1 To 2)
　　Dim t As Single

　　t = Timer
　　On Error GoTo errHndlr
　　fdName = "D:¥test¥"
　　v(0, 1) = "BookName"
　　v(0, 2) = "SheetName"
　　Set Ado = CreateObject("ADODB.Connection")
　　Ado.Provider = "Microsoft.Jet.OLEDB.4.0"
　　Ado.Properties("Extended Properties") = "Excel 8.0"
　　Set Reg = CreateObject("VBScript.RegExp")
　　Reg.Pattern = "(.*)(¥$'|¥$)$"
　　fn = Dir(fdName & "*.xls")
　　Do Until Len(fn) = 0&
　　　　bkName = fdName & fn
　　　　On Error Resume Next
　　　　Ado.Properties("Data Source") = bkName
　　　　Ado.Open
　　　　If Err.Number = 0& Then
　　　　　　Set AdoRs = Ado.OpenSchema(adSchemaTables)
　　　　　　i = i + 1
　　　　　　Do Until AdoRs.EOF Or (n > 65535)
　　　　　　　　If AdoRs Is Nothing Then Exit Do
　　　　　　　　tbName = AdoRs.Fields("TABLE_NAME").Value
　　　　　　　　With Reg.Execute(tbName)
　　　　　　　　　　If .Count > 0& Then
　　　　　　　　　　　　n = n + 1
　　　　　　　　　　　　v(n, 1) = bkName
　　　　　　　　　　　　v(n, 2) = .Item(0).SubMatches(0)
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　　　AdoRs.MoveNext
　　　　　　Loop
　　　　　　AdoRs.Close
　　　　　　Ado.Close
　　　　End If
　　　　Err.Clear
　　　　fn = Dir()
　　Loop
　　If i > 0& Then
　　　　Sheets.Add.Range("A1").Resize(n + 1, 2).Formula = v
　　End If
errHndlr:
　　If Err.Number = 0& Then
　　　　re = i & " Books & " & n & " Sheets was listed."
　　Else
　　　　re = Err.Number & vbLf & Err.Description
　　End If
　　Erase v
　　Set AdoRs = Nothing
　　Set Ado = Nothing
　　Set Reg = Nothing
　　Debug.Print i, n, Timer - t
　　MsgBox re
End Sub

（ぅーん...エラー処理甘いような...サンプルなのでご勘弁）

適当なフォルダに適当なxlsブック100ファイル、約300シートを読み込むのに、Workbooks.Openメソッドでは約30sec程かかります。（環境やファイルサイズによりますが）
対して、ADOで読み込むと約1/3の時間で読み込みできます。


...ですが上記コードは欠点があります。非表示のシートは読めません...orz
...さて、どうしたものか...って事で（当分の間）課題にしておきます。 X-(

■xlsブックのSheet一覧

ネタもないので...今日のレスから。
フォルダ選択して、フォルダ内のxlsブックのシート一覧を取得。

Option Explicit

Sub try()
　　Dim ws As Worksheet
　　Dim fd As String
　　Dim fn As String
　　Dim re As String
　　Dim i　As Long
　　Dim n　As Long
　　Dim v(0 To 65535, 1 To 2)

　　fd = FDselect
　　If Len(fd) = 0& Then Exit Sub
　　If MsgBox(fd & " の処理を行います。OK?", vbOKCancel) _
　　　　　　 = vbCancel Then Exit Sub
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　v(0, 1) = "BookName"
　　v(0, 2) = "SheetName"
　　On Error GoTo errHndlr
　　fn = Dir(fd & "*.xls")
　　Do Until Len(fn) = 0&
　　　　If Not fn Like ThisWorkbook.Name Then
　　　　　　With Workbooks.Open(Filename:=fd & fn, _
　　　　　　　　　　　　　　　　Updatelinks:=False, _
　　　　　　　　　　　　　　　　ReadOnly:=True)
　　　　　　　　i = i + 1
　　　　　　　　For Each ws In .Worksheets
　　　　　　　　　　n = n + 1
　　　　　　　　　　v(n, 1) = fd & fn
　　　　　　　　　　'次行と入れ替えるとHYPERLINKつき
　　　　　　　　　　v(n, 2) = ws.Name
　　　　　　　　　　'v(n, 2) = "=HYPERLINK(""[" & fd & fn & "]'" _
　　　　　　　　　　　　　　　　　　　　　& ws.Name & "'!A1"",""" _
　　　　　　　　　　　　　　　　　　　　　& ws.Name & """)"
　　　　　　　　Next ws
　　　　　　　　.Close Savechanges:=False
　　　　　　End With
　　　　End If
　　　　fn = Dir()
　　Loop

errHndlr:
　　If i > 0& Then
　　　　Worksheets.Add.Range("A1").Resize(n + 1, 2).Formula = v
　　End If
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　If Err.Number = 0& Then
　　　　re = i & " Books & " & n & " Sheets" & vbLf & "処理終了"
　　Else
　　　　re = Err.Number & vbLf & Err.Description
　　End If
　　MsgBox re
　　Erase v
　　Set ws = Nothing
End Sub
'---------------------------------------------------------------------
Private Function FDselect() As String 'FolderSelectFunction
　　Dim obj As Object
　　Dim ret As String

　　Set obj = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If obj Is Nothing Then Exit Function
　　On Error Resume Next
　　ret = obj.self.Path & "¥"
　　If Err.Number <> 0 Then
　　　　ret = obj.Items.Item.Path & "¥"
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　Set obj = Nothing
　　FDselect = ret
End Function

ぃや、特に変わった趣向は...ないです...:-(

■ChartObjects.Chart内のTextBoxes.Formula

(ぅーん...久し振りの新ネタ:-)
シート上のグラフオブジェクト内に、セルへリンクしたテキストボックスを配置する際、
グラフオブジェクトを配置したセル範囲内へリンクするとCPU使用率が上がる。

つまり、グラフの裏のセルにリンクするとCPU使用率がはねあがるという話です。
この場合のテキストボックスは、グラフの上に独立したテキストボックスを単純に重ねたものではなくて、チャートエリア内に作成するテキストボックスの事です。
テキストボックスのリンクセルがグラフとちょっとでも重なるとダメなようです。
グラフが画面上の表示範囲から外れると使用率は戻るので、どうもテキストボックスの画面描画を際限なく繰り返してるような印象を受けます。

[再現手順]
1.新規Book、新規シート上にグラフオブジェクトを追加する。
　（データなしで[グラフウィザード]-[完了]でも可）

2.グラフオブジェクトを選択して、数式バーに = と入れ、グラフの左上のコーナーあたりのセルをクリック。
　（グラフオブジェクトが重なっているセルを選択する）

3.グラフオブジェクト内にテキストボックスが追加される。
　この時タスクマネージャを起動しているとCPUに高負荷がかかっている事が確認できる。
　シートをスクロールしてグラフを画面外にすると負荷が下がる。
　（確認環境はWindows2000sp4/Excel2000sp3。2007では発生せず）

環境作成コードは下記。

Sub try()
　　Dim ch As Chart

　　Set ch = Sheets.Add.ChartObjects.Add(100, 100, 100, 100).Chart
　　With ch.TextBoxes.Add(20, 20, 20, 20)
　　　　.Border.ColorIndex = 0
　　　　.Formula = ch.Parent.TopLeftCell.Address(external:=True)
　　End With
　　Set ch = Nothing
End Sub

（結果）


環境によってはCPU使用率100%になります。
その状態で、ダイアログボックスなどを表示させたりすると、ロックがかかったような状態になる事があります。
例えばテキストボックス右クリック[テキストボックスの書式設定]など。
（ダイアログボックス表示まで時間がかかっていると考えられる...）
もしそうなったら、[esc]キー押しっ放しで復旧すると思います。