Excel VBA質問箱 IV

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

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


29426 / 76738 ←次へ | 前へ→

【52594】シート名記載が途中で止まる
質問  おすぎ  - 07/11/20(火) 19:36 -

引用なし
パスワード
   留意事項集アンケート集計.xls に「アンケートファイル一覧」を追加して
ユーザーが選択したファイルはうまく読み込めたのですが
そのファイルリストを元に、シート名を書き込みたかったのですが、うまく出来ませんでした。(ListSheetsName)

アンケートファイル一覧のシートイメージは次ぎのとおり
A1:現在の最終行書き込み位置(タイトル)
A2:現在の最終行書き込み位置情報

B2〜F2 各タイトル
B3〜  実際のファイル・・・
と成ってます。
----------------------------------
結果的に実施したい内容

ユーザーが選択したワークシートを読み込んでそのフォルダーとファイル名(パス)
そのときの、ワークシート名

上記のリストを頼りに、「留意事項集アンケート集計.xls」に各シートを複写
(同じシート名があれば、添え字を付ける)

以上 皆さんのお知恵をお貸し下さい。


----------------------------------------
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

0 hits

【52594】シート名記載が途中で止まる おすぎ 07/11/20(火) 19:36 質問
【52602】Re:シート名記載が途中で止まる ハチ 07/11/21(水) 11:03 発言
【52603】Re:シート名記載が途中で止まる neptune 07/11/21(水) 11:41 発言
【52635】Re:シート名記載が途中で止まる おすぎ 07/11/22(木) 20:47 回答

29426 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free