質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.49%

【ファイル名の読み込み】

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 2
  • VIEW 4,167

score 37

23歳OLです。

会社でマクロを組むことになりましたが、
初心者過ぎて全然よくわかりません。
お忙しいところ大変恐縮ですが、教えていただけないでしょうか。

※やりたいことがわかりづらいと思うのでもう少し詳しく書きます。

▼作っているもの
======================================
・複数のデータを読み込み
・その中身を一枚のシートにまとめ
・さらに読み込んだファイルの名前をシートに書き出してくれるツール
======================================

▼困っている内容
======================================
・複数のファイルは読み込むことができた。
しかし、ファイルの名前をシートに書き出してくる時点で、
ファイルの「名前」をシートに書き出すことができず、
代わりにファイルの「中身」を書き出してしまう。
→ファイルの名前をきちんととってこれるようにしたい。

======================================


▼現在書いているコード
======================================

Sub ReadMultiFiles()
' [[ 変数定義 ]]
Dim varFileName As Variant
Dim VWorkSheet As Worksheet
Dim NewWorkSheet As Worksheet
Dim SheetName As String
Dim Filename As Variant
Dim c As Long
Dim a As Variant
Dim dates As Worksheet

Set dates = Worksheets("データ")


' [[ ファイルパスからファイル名を取得 ]]
SheetName = "chushutu"
' [[ ファイル名で新しいシート作成 ]]
Set NewWorkSheet = CreateWorkSheet(SheetName)


' [[ 複数ファイルパス名を取得 ]]
varFileName = Application.GetOpenFilename(FileFilter:="(*.*),*.*", _
Title:="ファイルの選択", MultiSelect:=True)

' [[ ファイルパス取得できなかったら ]]
If IsArray(varFileName) = False Then
Exit Sub
End If

' [[ ファイルパス取得できたら ]]
    c = 0
    For Each Filename In varFileName

    ' [[ CSVファイルを開く ]]
    Dim buf As String, n As Long
    Open Filename For Input As #1
    c = c + 1
    Do Until EOF(1)
    Line Input #1, buf
    n = n + 1
   a = Split(buf, vbLf)
    Cells(n, c).Resize(UBound(a), 1) = Application.Transpose(a)
    Loop
  
    ' [[ CSVファイルを閉じる(保存無し) ]]
    Close #1
Next Filename




        dates.Activate
        
'ファイル名取得()
    Dim sPath As String, buf2 As String, cnt As Long
        With Application.FileDialog(msoFileDialogFolderPicker)  ' ▲
        If .Show <> True Then Exit Sub  ' ▲
        sPath = .SelectedItems(1)  ' ▲
    End With  ' ▲

    buf2 = Dir(sPath & "\*.*")
    Do While buf2 <> ""
        cnt = cnt + 1
        Cells(cnt + 12, 2) = buf
        buf2 = Dir()
    Loop









End Sub

' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
' [[ ]]
' [[ ワークシート名を指定したワークシートの作成 ]]
' [[ ]]
' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
Function CreateWorkSheet(WorkSheetName As String) As Worksheet

' 変数定義
Dim NewWorkSheet As Worksheet
Dim iCheckSameName As Integer

' ワークシートの作成
' ※一番最後に挿入
Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))

' 同じ名前ワークシートが無いか確認
iCheckSameName = 0
For Each WS In Sheets
If WS.Name = WorkSheetName Then
MsgBox "ワークシート名:" + WorkSheetName + " この名前は既に使われています。"
iCheckSameName = 1
End If
Next

'同じ名前のワークシートがなければ
If iCheckSameName = 0 Then
NewWorkSheet.Name = WorkSheetName
Set CreateWorkSheet = NewWorkSheet
End If

End Function


============================================================================
'ファイル名取得()
    Dim sPath As String, buf2 As String, cnt As Long
        With Application.FileDialog(msoFileDialogFolderPicker)  ' ▲
        If .Show <> True Then Exit Sub  ' ▲
        sPath = .SelectedItems(1)  ' ▲
    End With  ' ▲

    buf2 = Dir(sPath & "\*.*")
    Do While buf2 <> ""
        cnt = cnt + 1
        Cells(cnt + 12, 2) = buf
        buf2 = Dir()
    Loop

この部分単品で動かしたときは、きちんとファイルの名前をとってくることができ、ファイルの中身を吐き出したりはしない。

以上です。
お力を貸していただきたいです。
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+1

    buf2 = Dir(sPath & "\*.*") 
   Do While buf2 <> "" 
       cnt = cnt + 1 
       Cells(cnt + 12, 2) = buf 
       buf2 = Dir() 
   Loop 
この辺の
       Cells(cnt + 12, 2) = buf 
この行なんですが。
式の右側は「buf」ではなくて「buf2」ではないでしょうか?
bufだとその上のループで最後に読み込んだファイルの最後の行が出力されるような気がします。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/02/27 09:30

    これでした!単純な筆記ミスでした!ありがとうございました!(^^)!

    キャンセル

0

何がしたいのかわからなかったので、とりあえずこんな風にしてみました。
気になるところは色々ありますが、極力変更しない形でそれっぽくしてみました。

Sub ReadMultiFiles()
    ' [[ 変数定義 ]]
    Dim varFileName As Variant
    Dim VWorkSheet As Worksheet
    Dim NewWorkSheet As Worksheet
    Dim SheetName As String
    Dim Filename As Variant
    Dim c As Long
    Dim a As Variant
    Dim dates As Worksheet
    
    Set dates = Worksheets("データ")
    
    ' [[ ファイルパスからファイル名を取得 ]]
    SheetName = "chushutu"
    ' [[ ファイル名で新しいシート作成 ]]
    Set NewWorkSheet = CreateWorkSheet(SheetName)
    
    ' [[ 複数ファイルパス名を取得 ]]
    varFileName = Application.GetOpenFilename(FileFilter:="(*.*),*.*", _
    Title:="ファイルの選択", MultiSelect:=True)
    
    ' [[ ファイルパス取得できなかったら ]]
    If IsArray(varFileName) = False Then
        Exit Sub
    End If
    
    ' [[ ファイルパス取得できたら ]]
    c = 0
    Dim i As Long
    i = 1
    For Each Filename In varFileName

        ' [[ CSVファイルを開く ]]
        Dim buf As String, n As Long
        Open Filename For Input As #1
        c = c + 1
        n = 0
        Do Until EOF(1)
            Line Input #1, buf
            n = n + 1   ' こうかな?
            'a = Split(buf, vbLf)   ' line feedが区切り文字のCSVデータ???
            a = Split(buf, ",")     ' よくわかんなかったので、とりあえずカンマで区切ってみた。
                Cells(n, c).Resize(UBound(a) + 1, 1) = Application.Transpose(a) ' こうかな?
            n = n + UBound(a) ' こうかな?
        Loop
        
        ' [[ CSVファイルを閉じる(保存無し) ]]
        Close #1
        
        ' こうかな?
        dates.Cells(i, 1).Value = Dir(Filename)
        i = i + 1
    Next Filename

    ' これいらないかな?
'    dates.Activate
'
'    'ファイル名取得
'    Dim sPath As String, buf2 As String, cnt As Long
'        With Application.FileDialog(msoFileDialogFolderPicker)  ' ▲
'        If .Show <> True Then Exit Sub  ' ▲
'        sPath = .SelectedItems(1)  ' ▲
'    End With  ' ▲
'
'    buf2 = Dir(sPath & "\*.*")
'    Do While buf2 <> ""
'        cnt = cnt + 1
'        Cells(cnt + 12, 2) = buf
'        buf2 = Dir()
'    Loop

    ' こうかな?
    dates.Activate
    
End Sub

' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
' [[ ]]
' [[ ワークシート名を指定したワークシートの作成 ]]
' [[ ]]
' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
Function CreateWorkSheet(WorkSheetName As String) As Worksheet

    ' 変数定義
    Dim NewWorkSheet As Worksheet
    Dim iCheckSameName As Integer
    
    ' ワークシートの作成
    ' ※一番最後に挿入
    Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    ' 同じ名前ワークシートが無いか確認
    iCheckSameName = 0
    For Each WS In Sheets
        If WS.Name = WorkSheetName Then
            MsgBox "ワークシート名:" + WorkSheetName + " この名前は既に使われています。"
            iCheckSameName = 1
        End If
    Next
    
    '同じ名前のワークシートがなければ
    If iCheckSameName = 0 Then
        NewWorkSheet.Name = WorkSheetName
        Set CreateWorkSheet = NewWorkSheet
    End If

End Function

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/02/26 18:04

    お返事ありがとうございます。
    これで試してみたのですが、やはりファイルの名前を取得することができません。

    キャンセル

  • 2015/02/26 21:46

    dates.Cells(i, 1).Value = Dir(Filename)
    この部分でファイル名を取ってくると思うのですが、ご希望とは異なりましたか?

    キャンセル

  • 2015/02/27 09:30

    すみません単純なミスでした。また何かありましたらご教授ください。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.49%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る