| |
留意事項集アンケート集計.xls に「アンケートファイル一覧」を追加して
ユーザーが選択したファイルはうまく読み込めたのですが
そのファイルリストを元に、シート名を書き込みたかったのですが、うまく出来ませんでした。（ListSheetsName）
アンケートファイル一覧のシートイメージは次ぎのとおり
A1:現在の最終行書き込み位置（タイトル）
A2:現在の最終行書き込み位置情報
B2〜F2 各タイトル
B3〜 実際のファイル・・・
と成ってます。
----------------------------------
結果的に実施したい内容
ユーザーが選択したワークシートを読み込んでそのフォルダーとファイル名（パス）
そのときの、ワークシート名
上記のリストを頼りに、「留意事項集アンケート集計．ｘｌｓ」に各シートを複写
（同じシート名があれば、添え字を付ける）
以上 皆さんのお知恵をお貸し下さい。
----------------------------------------
Option Explicit
'
Dim vntFileName As Variant
Dim vntGetFileName As Variant
'
'
' 引数で指定されたファイル等を一覧にする
'
Sub MakeFileList(vntFileName)
' vntFileName = 配列のファイル名変数
Dim StrMyseetName As String
Dim OldSheet As Worksheet
Dim i As Integer
'
' 定数設定
StrMyseetName = "アンケートファイル一覧"
'
' 指定シート存在確認 False = 無し→新規作成
Set OldSheet = ActiveSheet
If chkSheetNM(StrMyseetName) = False Then
With Worksheets.Add()
.Name = StrMyseetName
End With
' 項目作成
i = 2
With Worksheets(StrMyseetName)
.Range("B2") = "フォルダ/ファイル名"
.Range("C2") = "シート名"
.Range("D2") = "シート名"
.Range("E2") = "シート名"
.Range("F2") = "シート名"
.Range("B1") = i
.Range("A1") = "現在の最終行書き込み位置"
End With
Else
i = Worksheets(StrMyseetName).Cells(1, 2)
End If
If IsArray(vntFileName) Then
For Each vntGetFileName In vntFileName
'ファイル名/フォルダ名の書き出し
i = i + 1
Worksheets(StrMyseetName).Cells(i, 2) = vntGetFileName
Worksheets(StrMyseetName).Cells(1, 2) = i
Next
End If
'
Function chkSheetNM(mySheetName) As Boolean
'現在のブックのシート(含グラフシート)の存在チェック
'True=シート名有り,False=シート名無し
'2004/04/10 pPoy
Dim wk As Object
chkSheetNM = False
'シート名の一覧
For Each wk In Sheets
'大文字小文字を区別しない
If LCase(mySheetName) = LCase(wk.Name) Then
chkSheetNM = True
Exit For
End If
Next wk
'
End Function
'/////////////////////////////////////////////////////////////////
'// ファイル一覧のシート名を一覧に作成する
'// メイン subに実際に処理した内容を引き渡す
'// 吐き出し引数
'// 現在のファイル名 と そのセル位置の隣
'/////////////////////////////////////////////////////////////////
Sub ListSheetsName()
Dim objSheet As Object
Dim strFile As String
Dim StrMyseetName As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim mySheetCnt As Integer
Dim mySheetNam As String
Dim myAnksum As String
' 定数設定
StrMyseetName = "アンケートファイル一覧"
If chkSheetNM(StrMyseetName) = False Then
MsgBox StrMyseetName & "が見つかりません。" & vbCrLf & "終了します。", vbOKOnly, "確認"
Exit Sub
Else
' 書き込みセル数を確認 3未満は終了
j = Worksheets(StrMyseetName).Cells(1, 2)
If j < 3 Then
MsgBox "ファイルリストが無いかリスト数が適正で有りません。" & vbCrLf & "終了します。", vbOKOnly, "確認"
Exit Sub
End If
j = j - 1
For i = 3 To j
strFile = Worksheets(StrMyseetName).Cells(i, 2) 'ファイル名セット
If strFile <> "" Then
Workbooks.Open(strFile).Activate
mySheetCnt = ThisWorkbook.Sheets.Count
For k = 1 To mySheetCnt
l = k + 3
Debug.Print "k=" & k
Debug.Print "mySheetCnt=" & mySheetCnt
Workbooks(myAnksum).Sheets(StrMyseetName).Cells(i, l) = Sheets(k).Name
Next k
Workbooks(strFile).Close SaveChanges:=False
Else
Exit Sub
End If
Next
End If
End Sub
'
'//////////////////////////////////////////////////////////////////////
' 引数に指定された ファイルのシート名をアクティブセルから右に書き出し
' 引数 myFileName ファイルネーム
' 引数 gyosel = 行 retusel = 列
'//////////////////////////////////////////////////////////////////////
'
Sub mySheetName(myFileName As String, gyosel As Integer, retusel As Integer)
Dim i As Integer
Dim mySheetCnt As Integer
Dim mySheetNam As String
Dim myAnksum As String
Dim StrMyseetName As String
myAnksum = "留意事項集アンケート集計.xls"
StrMyseetName = "アンケートファイル一覧"
Workbooks.Open(myFileName).Activate
mySheetCnt = ThisWorkbook.Sheets.Count
For i = 1 To mySheetCnt
Debug.Print "i=" & i
Debug.Print "mySheetCnt=" & mySheetCnt
mySheetNam = Sheets(i).Name
Workbooks(myAnksum).Sheets(StrMyseetName).Cells(gyosel, retusel) = mySheetNam
Next i
Workbooks(myFileName).Close SaveChanges:=False
End Sub
|
|
おすぎ
- 07/11/20(火) 19:36 -
