Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

13202 / 13665 ﾂﾘｰ

←次へ　｜　前へ→

▼

【6649】LAN環境で・・・ やま 03/7/17(木) 10:35

【6653】Re:LAN環境で・・・ ichinose 03/7/18(金) 3:03

【6654】Re:LAN環境で・・・ やま 03/7/18(金) 9:41


	【6649】LAN環境で・・・

やま - 03/7/17(木) 10:35 -


	引用なし

	パスワード

エクセルのユーザーフォームにラジオボタンを数個配置し、アンケートを作りたいと思います。アンケートの集計にはLAN上の任意のコンピュータ内のマイドキュメントフォルダに「集計.xls」のブックを作成し、その中にセルA1に回答者Aの氏名B1に一問目の解答結果、C2に二問目の解答結果、という風に集計していきたいのです。２番目の回答者は下の行にずらして解答結果を入力させたいのですが、LAN上のコンピュータ全てのコンピュータ名を取得し、リストボックスに表示させ、リストボックス内のコンピュータを選び、さらにその中の「集計.xls」を開いて結果を保存するようなコードはどう記述すれば良いのでしょうか？お願いします。


	【6653】Re:LAN環境で・・・

ichinose - 03/7/18(金) 3:03 -


	引用なし

	パスワード

▼やまさん：
こんばんは。
>エクセルのユーザーフォームにラジオボタンを数個配置し、アンケートを作りたいと思います。アンケートの集計には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」が取得できましたが、
確認してください。


	【6654】Re:LAN環境で・・・

やま - 03/7/18(金) 9:41 -


	引用なし

	パスワード

ご教授ありがとうございます。ただ、失礼なこととは思いますが、現在多忙のためすぐに試すことが出来ません。非常に残念です。後日、試した後、再度ご返事差し上げたいと思います。ありがとうございました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

13202 / 13665 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free