| |
▼やま さん：
こんばんは。
>エクセルのユーザーフォームにラジオボタンを数個配置し、アンケートを作りたいと思います。アンケートの集計にはLAN上の任意のコンピュータ内のマイドキュメントフォルダに「集計.xls」のブックを作成し、その中にセルA1に回答者Aの氏名B1に一問目の解答結果、C2に二問目の解答結果、という風に集計していきたいのです。２番目の回答者は下の行にずらして解答結果を入力させたいのですが、LAN上のコンピュータ全てのコンピュータ名を取得し、リストボックスに表示させ、リストボックス内のコンピュータを選び、さらにその中の「集計.xls」を開いて結果を保存するようなコードはどう記述すれば良いのでしょうか？お願いします。
もっと他に良い方法があるのかもしれませんが・・・。
取りあえず、「xx:\My Documents\集計.xls」を探すということで・・・、
ユーザーフォーム（Userfrom1）内にリストボックス（Listbox1）とコマンドボタン
（Commandbutton1）を配置してください。
参照設定で「MICROSOFT SHELL CONTROLS AND AUTOMATION」をチェックして下さい。
（これしないと、エラーになりました、疑問ですが・・）
標準モジュール（Module1）に、
'=========================================
Sub main()
UserForm1.Show
End Sub
標準モジュール（Module2）に、
'============================================
Function get_compnm() 'コンピュータ名の取得
Dim nm()
Dim myshell As Shell
' ↑ここがObjectやVariantだとエラーになる不思議
' よって、上述の参照設定が必要
Set myshell = CreateObject("Shell.Application")
With myshell
Set fol = .NameSpace(18) 'Folderオブジェクト
Set fc = fol.Items 'FolderItemsコレクション
jdx = 0
For idx = 1 To fc.Count - 1
wk = fc.Item(idx).Name
ReDim Preserve nm(1 To jdx + 1)
nm(jdx + 1) = wk
jdx = jdx + 1
Next
End With
If jdx > 0 Then
get_compnm = nm()
Else
get_compnm = ""
End If
Set myshell = Nothing
End Function
'==================================================
Function get_subpath(Optional mydir As String = "") As String
'指定されたパスにあるフォルダパスの取得
Static sdx
Static myshell As Shell
' ↑ここがObjectやVariantだとエラーになるのが不思議
Static fol As Object
Static fc As Object
If mydir <> "" Then
Set myshell = CreateObject("Shell.Application")
Set fol = myshell.NameSpace(mydir)
Set fc = fol.Items
sdx = 0
End If
If sdx <= fc.Count - 1 Then
get_subpath = fc.Item(sdx).Path
sdx = sdx + 1
Else
get_subpath = ""
Set fc = Nothing
Set fol = Nothing
Set myshell = Nothing
End If
End Function
Userform1のモジュールに
'=====================================================
Private Sub CommandButton1_Click()
Dim compnm As String
Dim fld As String
Dim bk As Workbook
With ListBox1
If .ListIndex >= 0 Then
compnm = .Value
fld = get_subpath("\\" & compnm)
Do While fld <> ""
Set bk = book_open(fld & "\my documents\集計.xls")
If Not bk Is Nothing Then
MsgBox bk.Name & "取得"
'処理
bk.Close False
Exit Do
End If
fld = get_subpath
Loop
End If
End With
End Sub
'========================================
Private Sub UserForm_Initialize()
Dim compnm
compnm = get_compnm
If VarType(compnm) = 8204 Then
ListBox1.List = compnm
End If
End Sub
'=========================================
Function book_open(flnm) As Workbook
On Error Resume Next
Set book_open = Workbooks.Open(flnm)
If Err.Number <> 0 Then
Set book_open = Nothing
End If
On Error GoTo 0
End Function
で指定されたコンピュータの「My Documents\集計.xls」が取得できましたが、
確認してください。
|
|
ichinose
- 03/7/18(金) 3:03 -
