gooポイントが当たる質問投稿キャンペーン>>

題名の通りですが、詳しく書くと↓
<やりたいこと>
自ブック(マクロを実行する本体)と同じ場所に複数のサブフォルダがあり、サブフォルダの中にはいくつかの .xlsx ファイルが存在する。
この複数のサブフォルダに存在する .xlsxファイルを全て開きたい。

<今、躓いている所>
サブフォルダ内のファイル名取得(拡張子を指定)のコードをどのように記述するのか


同じフォルダ内の .xlsxファイルを全て開くコードは次のようにしてみました。
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub SameFolderBook_Open()
Dim FileName As String
Dim wb As Workbook
Dim IsBookOpen As Boolean
Dim myPath As String

myPath = ThisWorkbook.Path & "\"   '今開いているブックのパスを取得
FileName = Dir(myPath & "*.xlsx", vbDirectory)  'myPathの*.xlsxのファイル名を取得
  Do While FileName <> ""
    For Each wb In Workbooks
      If wb.Name = FileName Then  '既にブックが開いているときの処理
        IsBookOpen = True
    Exit For
      End If
    Next wb
      If IsBookOpen = False Then 'ブックを開く処理
        Application.StatusBar = "データを読込中..."
        Application.ScreenUpdating = False
        Workbooks.Open myPath & FileName, ReadOnly:=True
        ActiveWindow.Visible = False
      End If
    IsBookOpen = False
    FileName = Dir()
  Loop
 Application.StatusBar = False
 Application.ScreenUpdating = True
 ThisWorkbook.Activate
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
サブフォルダ取得なので、Dir()かFSOを使ったコードになるとは思うのですが、コードが思い浮かばず・・・
可能ならば、上記のコードも活かしたい。

このQ&Aに関連する最新のQ&A

A 回答 (1件)

こんにちは。


>サブフォルダ内のファイル名取得(拡張子を指定)のコードをどのように記述するのか

雑な書き方で、質問者さんのコードを汚してしまいましたが、こんな感じでループすればどうでしょうか。
たぶん、時間をかければ、私の書いた程度なら書けたはずだと思います。

ファイル名取得なら、
Dir(myPath & "*.xlsx", vbNormal)  か、ただの Dir(myPath & "*.xlsx")で良いはずです。

ひとつだけ気になるのは、
 ActiveWindow.Visible = False
 の部分ですが、後、どうやって収拾するのでしょうか?

'//

Sub SameFolderBook_OpenN()
'No. 9037311
 Dim FileName As String
 Dim wb As Workbook
 Dim IsBookOpen As Boolean
 Dim myPath As String
 Dim FolderLists As Variant
 Dim FSO As Object
 Dim objFolder As Object
 Dim i As Long
 Dim obj As Object
 Dim pt As Variant
 Dim buf As String
 myPath = ThisWorkbook.Path & "\"   '今開いているブックのパスを取得
 ReDim FolderLists(0)
 FolderLists(0) = myPath
 i = i + 1
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder(myPath)
 For Each obj In objFolder.SubFolders
  ReDim Preserve FolderLists(i)
  If Right$(myPath & obj.Name, 1) <> "\" Then
    FolderLists(i) = myPath & obj.Name & "\"
  Else
    FolderLists(i) = myPath & obj.Name
  End If
  i = i + 1
 Next
 
 For Each pt In FolderLists
 FileName = Dir(pt & "*.xlsx",vbNormal)  'myPathの*.xlsxのファイル名を取得
  Do While FileName <> ""
   For Each wb In Workbooks
    If wb.Name = FileName Then '既にブックが開いているときの処理
     IsBookOpen = True
     Exit For
    End If
   Next wb
   If IsBookOpen = False Then 'ブックを開く処理
    Application.StatusBar = "データを読込中..."
    Application.ScreenUpdating = False
    Workbooks.Open pt & FileName, ReadOnly:=True
    ActiveWindow.Visible = False
   End If
   IsBookOpen = False
   FileName = Dir()
  Loop
 Next pt
 Application.StatusBar = False
 Application.ScreenUpdating = True
 ThisWorkbook.Activate
End Sub
'///
    • good
    • 1
この回答へのお礼

教えて頂いたコードでうまく動作しました。
開くファイルの数が多い(72個)のか、メモリ不足表示が出ました。メモリ自体は8GBなんですが・・・(苦笑

>ひとつだけ気になるのは、
>  ActiveWindow.Visible = False
> の部分ですが、後、どうやって収拾するのでしょうか?
すいません、説明なく入れていました。
自ブックにINDIRECT関数でデータ値を外部参照させている部分があり、データ値のブックは操作する人に見えなくてもよいという理由からです。

課題は解決したので、No.1をベストアンサーに選ばせていただきます。
ありがとうございました。また別の機会によろしくお願い致します。

お礼日時:2015/08/05 19:55

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QExcel VBAでサブフォルダ内のファイルを呼び出したい

フォルダの下に複数階層のサブフォルダがあり、その下に複数のエクセルブックがあります。これらのブックのシート複数ですが、名前は統一されています。
これらのファイルを呼び出した上でのある特定の名前のシートを呼出し、それぞれ1枚のシートに上から順に貼り付けたいと考えています。
よろしくご教授お願いします

Aベストアンサー

こんばんわ matchy4649 さん
ん~すっかり夜ですね。晩御飯の支度をする前にちょちょいと作って回答を投下しておきましょう。
以下は二階層ならば正常に動作します。
c:\workの部分はあなたの任意のフォルダ名とし、以下を新規bookに書き込んでください。




Sub test()
directory = "C:\work"
For Each fl In CreateObject("Scripting.FileSystemObject").GetFolder(directory).subfolders: fn = fn & directory & "\" & fl.Name & "/": Next: If InStr(fn, "\") > 0 Then folderlist = Split(Left(fn, Len(fn) - 1), "/") Else folderlist = Array("")
For i = 0 To UBound(folderlist)
fn = "": For Each fl In CreateObject("Scripting.FileSystemObject").GetFolder(folderlist(i)).Files: fn = fn & fl.Name & "/": Next: If InStr(fn, "/") > 0 Then filelist = Split(Left(fn, Len(fn) - 1), "/") Else filelist = Array("")
For j = 0 To UBound(filelist)
Workbooks.Open Filename:=folderlist(i) & "\" & filelist(j): Sheets("3").Select: Sheets("3").Copy Before:=Workbooks(ThisWorkbook.Name).Sheets(1): Sheets("3").Name = Left(filelist(j), Len(filelist(j)) - 4) & "3"
Next
Next
End Sub


どうですか?実行してみましたか?新規bookには
「各ファイル名&3」という名前で全てのbookシート3が新規bookに追加されました。
詳細を頂けなかったのでこれは二階層専用です。ちなみに順番は気にしませんでした。どうしてもというならば実装しますが・・・。
少なからず現状の仕様みたし、現在おっしゃるディレクトリ構成ならば正常に動作するはずです。



追加処理・処理違い・補足等あればいってください。

こんばんわ matchy4649 さん
ん~すっかり夜ですね。晩御飯の支度をする前にちょちょいと作って回答を投下しておきましょう。
以下は二階層ならば正常に動作します。
c:\workの部分はあなたの任意のフォルダ名とし、以下を新規bookに書き込んでください。




Sub test()
directory = "C:\work"
For Each fl In CreateObject("Scripting.FileSystemObject").GetFolder(directory).subfolders: fn = fn & directory & "\" & fl.Name & "/": Next: If InStr(fn, "\") > 0 Then folderlist = Spl...続きを読む

Qフォルダ内の全てのBookに同じ処理を繰り返す

フォルダ内にエクセルファイルが約3,000個あります。
この全てのBookに同じ処理をしたいのですが、マクロで繰り返す方法がわからないので教えて下さい。
処理をする内容は簡単なもので、マクロで作りました。

・ 各Bookには1つのシートしか存在せず、シート名は重要ではないので全て「Sheet1」になっています。
・ 各Bookのデータの配置や表形式は同じです。
・ レコードの行数がBookによって異なります。

処理の内容をマクロで作るところまではできましたが、知識がないためタイムアウトです。

ご教示宜しくお願い致します。

Aベストアンサー

だいたいこんな流れで。

sub macro1()
 dim myPath as string
 dim myFile as string

 mypath = "C:\test\"

’指定フォルダのブックを順繰り拾う
 myfile = dir(mypath & "*.xls*")
 do until myfile = ""

 ’ブックを開いて処理を行い保存して閉じる
  workbooks.open mypath & myfile
  activesheet.range("A1") = "DONE"
  activeworkbook.close true

  myfile = dir()
 loop
end sub


必要に応じて
・画面の表示を抑制する
・再計算を手動にする
といった手管を追加して高速化を図ります。

Qエクセル マクロで指定フォルダを開く

エクセルにて
指定フォルダを開く、マクロがあれば教えて頂けないでしょうか。
よろしくお願いいたします。

Aベストアンサー

こんにちは。

こういうものですか?
開くフォルダを変えたいときは targ に与えるパスを変更します。

Sub OpenFolders()
Dim targ As String
targ = "C:\"
Shell "C:\Windows\Explorer.exe " & targ, vbNormalFocus
End Sub

QVBAにて複数フォルダのエクセルファイルからデータ抽出を行いたいのですが…

現在、下記の方法で複数のブックからデータを抽出し、
一覧表示をしています。(一覧表示をしているブックを仮にAとします。)
今のままだと、同一フォルダ内のブックしか抽出されません。
これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか?

簡単に例をあげると、
フォルダ(1)の中にAを入れておいて
フォルダ(1)の下にあるサブフォルダ(1)、サブフォルダ(2)の中にあるブックからデータの抽出を行いたいのです。

現在つかっているVBAは
Sub 抽出用()
Dim FName As String
Dim Folder As String
Dim wb As Workbook
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
Folder = ThisWorkbook.Path & "\"
i = 1: j = 1
Worksheets(1).Cells.ClearContents
FName = Dir(Folder & "*.xls")
Do While FName <> ""
If FName <> ThisWorkbook.Name Then
Workbooks.Open (Folder & FName)
Workbooks(Workbooks.Count).Worksheets(5).Rows("1:1").Copy _
ThisWorkbook.Worksheets(5).Cells(i + 3, 1)
Workbooks(Workbooks.Count).Close
Application.StatusBar = j & "ファイル処理済み"
i = i + 1: j = j + 1
End If
FName = Dir()
Loop
Application.StatusBar = ""
Application.ScreenUpdating = True
MsgBox ("完了しました")

End Sub

です。
いいお知恵があれば、よろしくお願い致します。

現在、下記の方法で複数のブックからデータを抽出し、
一覧表示をしています。(一覧表示をしているブックを仮にAとします。)
今のままだと、同一フォルダ内のブックしか抽出されません。
これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか?

簡単に例をあげると、
フォルダ(1)の中にAを入れておいて
フォルダ(1)の下にあるサブフォルダ(1)、サブフォルダ(2)の中にあるブックからデータの抽出を行いたいのです。

現在つかっているVBAは
Sub 抽出用()
Dim FName As S...続きを読む

Aベストアンサー

こんばんは。

ご自身のコードではありませんね。
>Workbooks(Workbooks.Count)
問題は発生しないけれども、せっかく、前のコードで、オブジェクトを取得しているのですから、それを新たにオブジェクトを取るのはよくないです。たぶん、癖だと思いますが、これは直したほうがよいでしょうね。

なお、シート元が存在しないときのエラーについては、On Error Resume Next ですから、そのまま進んでしまいます。コピー先のシートが存在しない場合は、アクティブシートにコピーされます。本来は、Index を使用せずに、明示的なシート名を使ったほうがよいとは思いますが、それはVariant ですから、選択の自由にしてあります。

ファイル数が、極端に多いと、おそらく、途中で、メモリがなくなるように思います。指定フォルダのミスを含めて、LIMITでオープンファイル数の制限を設けたら良いかと思います。
'---------------------------------------------

Dim objFs As Object
Dim arFiles() As Variant
Dim fCount As Long
Sub ExctactingData()
  Dim FName As String
  Dim myFolder As String
  Dim wb As Workbook
  Dim i As Long
  Dim j As Long
  Dim fn As Variant
  Dim myBook As Workbook
  Dim ret As Long
  '
  Set objFs = Nothing 'オブジェクトの初期化
  Erase arFiles '配列の初期化
  fCount = 0 'ファイルカウントの初期化
  ''-----------------------------
  'User Setting
  Set myBook = ThisWorkbook    'コピー先ブック
  myFolder = myBook.Path & "\"  '検索フォルダ
  Const mSH_NO As Variant = 5   'コピー先シート(シート名可)
  Const oSH_NO As Variant = 5   'コピー元シート ( '' )
  i = 4              '書き出す最初の行
  Const LIMIT As Integer = 500   'ファイルオープン・限界数
  ''-----------------------------
  
  If Dir(myFolder) = "" Then
    MsgBox myFolder & " は存在しません。", vbQuestion
    Exit Sub
  End If
  
  On Error Resume Next
  'Application.ScreenUpdating = False
  'データの消去
  If WorksheetFunction.Count(myBook.Worksheets(mSH_NO).Cells) > 1 Then
    If MsgBox("既にデータがありますが、削除してよろしいですか?", vbQuestion + vbOKCancel) = vbOK Then
      myBook.Worksheets(mSH_NO).Cells.ClearContents
    Else
      Exit Sub
    End If
  End If
  
  'ファイルシステム・オブジェクトの生成
  Set objFs = CreateObject("Scripting.FileSystemObject")
  
  fCount = MyFileSearch(myFolder, FName, fCount)
  If ret > -1 Then
  If fCount > LIMIT Then
    If MsgBox("ファイル数が" & fCount & " です。トラブルを起こす可能性がありますが、続行しますか?", vbInformation + vbOKCancel) = vbCancel Then
     Set objFs = Nothing
     Exit Sub
    End If
  End If
  For Each fn In arFiles
  Debug.Print fn
    If fn <> myBook.Name Then
    With Workbooks.Open(fn)
      .Worksheets(oSH_NO).Rows(1).Copy myBook.Worksheets(mSH_NO).Cells(i, 1)
       .Close False
       i = i + 1
    End With
    End If
   Next
   End If
  'Application.ScreenUpdating = True
  Set objFs = Nothing
  If fCount > -1 Then
    MsgBox fCount & " 個のファイルを完了しました", vbInformation
  Else
    MsgBox "エラーが発生して、ファイル名が取得できませんでした。", vbCritical
  End If
  
End Sub

Function MyFileSearch(strDir As String, strFile As String, fCount As Long) As Long
  On Error GoTo ErrHandler
  Const EXT As String = "*.xl?" '拡張子の指定
  Dim objDir As Object
  Dim objFile As Object
  Set objDir = objFs.Getfolder(strDir)
  Set objFile = objDir.Files
  For Each objFile In objDir.Files
    If objFile Like EXT Then
      ReDim Preserve arFiles(fCount)
      arFiles(fCount) = objFile.Path
      fCount = fCount + 1
    End If
  Next
  For Each objDir In objDir.SubFolders
    If objDir.Attributes <> 22 Then
      Call MyFileSearch(objDir.Path, strFile, fCount)
    End If
  Next
  MyFileSearch = fCount
  Set objFs = Nothing
  Exit Function
ErrHandler:
  MyFileSearch = -1
End Function

こんばんは。

ご自身のコードではありませんね。
>Workbooks(Workbooks.Count)
問題は発生しないけれども、せっかく、前のコードで、オブジェクトを取得しているのですから、それを新たにオブジェクトを取るのはよくないです。たぶん、癖だと思いますが、これは直したほうがよいでしょうね。

なお、シート元が存在しないときのエラーについては、On Error Resume Next ですから、そのまま進んでしまいます。コピー先のシートが存在しない場合は、アクティブシートにコピーされます。本来は、Index を使用...続きを読む

QExcelVBAでBookを開く時にファイル名の一部だけを指定で

VBA初心者です。
ExcelVBAで決まったフォルダーのファイルを開きたいのですが、ファイル名が固定した文字+日付になっているため、この固定した文字だけでこのファイルを開く方法を教えて下さい。このフォルダーには2つファイルがありますが、もう1つは全く違うファイル名です。

Aベストアンサー

> ワイルドカード"*"はどんな時に使えるのですか

Dir関数を使用時の"*" (アスタリスク) および "?" (疑問符) のワイルドカード文字については、
VBAのヘルプを参照し、特に「使用例」のコードを理解してください。

その他 VBAでの ワイルドカード使用に関しては、ヘルプで Like で検索して、
Like 演算子 を参照し、同じく「使用例」のコードを理解されたら宜しいかと思います。


> 通常のOPENメソッドでの> ファイル名指定では使えないと思うのですが。

Workbooks.Openメソッドの1番目の引数は、ファイルが特定出来るように指定する必要が
ありますので、当然 ワイルドカード文字は、使用出来ません。

殆ど、フルバスで指定します。 もし、パス名を省略すると カレントホルダ内のファイルを
指定したことになります。([メニュー]-->[オプション]-->[全般]タブの中で指定)

QExcelのVBAでの複数階層からのフォルダ名の取得

ExcelのVBAでの複数階層からのフォルダ名の取得

下記階層に対して以下の処理をExcelのVBAで行うにはどしたら良いか、
申し訳ありませんが、どうか教えて頂きたく思います。

C:\test1
  ├\aaa\ddd
  │   ├\xxx1\
  │   └\yyy2\
  │
  ├\bbb\ddd
  │   └\xxx3\
  │
  │
  └\ccc\ddd
      ├\xxx4\
      ├\xxx5\
      └\zzz6\

1 C:\test1を指定する
2 1で指定した中にある各\dddフォルダ内にあるフォルダ名を順に取得する
3 2で取得したフォルダ名をExcelのSheet1のA1から順に書き出す

Excel
  A    B    C    D    E
1 xxx1
2 yyy2
3 xxx3
4 xxx4
5 xxx5
6 zzz6
7
8
9
 Sheet1 Sheet2 Sheet3

勉強不足で申し訳ありません。
どうぞ宜しくお願い致します。

Aベストアンサー

※サンプルプログラムです。

Public 設定セル As Range

Sub フォルダ処理()
 Const 開始フォルダ = "C:\TEST1"
 Dim objFSO As Object
 Dim objFolder As Object
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(開始フォルダ)
 Set 設定セル = Range("A1")
 Call 該当フォルダ取得(objFolder)
 Set objFolder = Nothing
 Set objFSO = Nothing
End Sub

Sub 該当フォルダ取得(フォルダパス As Object)
 Dim objSubFolder As Object
 For Each objSubFolder In フォルダパス.SubFolders
   Call 該当フォルダ取得(objSubFolder)
 Next
 If UCase(フォルダパス.ParentFolder.Name) = "DDD" Then
   設定セル = フォルダパス.Name
   Set 設定セル = 設定セル.Offset(1)
 End If
 Set objSubFolder = Nothing
End Sub

※サンプルプログラムです。

Public 設定セル As Range

Sub フォルダ処理()
 Const 開始フォルダ = "C:\TEST1"
 Dim objFSO As Object
 Dim objFolder As Object
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(開始フォルダ)
 Set 設定セル = Range("A1")
 Call 該当フォルダ取得(objFolder)
 Set objFolder = Nothing
 Set objFSO = Nothing
End Sub

Sub 該当フォルダ取得(フォルダパス As Object)
 Dim objSubFolder As Object
 For E...続きを読む

Q複数フォルダに格納されたファイル名取得VBA

お世話になっております。

あるフォルダに複数のフォルダが格納されており、更にそのフォルダの中にあるファイルの情報を取得するプログラムを書いたのですが、実行すると下記のようなエラーとなってしまいます。

■エラー
プロシージャの呼び出し、または引数が不正です

下から3行目、「buf = Dir()」が問題であることはわかるのですが、
何が問題でどのように解決したらいいかわかりません。

どなたかご教授の程よろしくお願い致します(>_<)

------------------------------------------------------------------------
Sub test()

Dim buf As String
Dim fName As String
Dim msg As String

buf = Dir("*.*", vbDirectory)

Do While buf <> ""
If GetAttr(buf) And vbDirectory Then
If buf <> "." And buf <> ".." Then
fName = Dir(CurDir & "\" & buf & "\" & "*.jpg")
Do While fName <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
Cells(cnt, 2) = fName
msg = msg & buf & "\" & fName & vbCrLf
fName = Dir()
Loop
MsgBox msg

End If
End If
buf = Dir()
Loop

End Sub
------------------------------------------------------------------------

これが実現できないと細かい作業を毎日繰り返す事となり、
かなり業務不可が高いです。。

繰り返しになってしまいますが、どなたかご回答よろしくお願い致します。

お世話になっております。

あるフォルダに複数のフォルダが格納されており、更にそのフォルダの中にあるファイルの情報を取得するプログラムを書いたのですが、実行すると下記のようなエラーとなってしまいます。

■エラー
プロシージャの呼び出し、または引数が不正です

下から3行目、「buf = Dir()」が問題であることはわかるのですが、
何が問題でどのように解決したらいいかわかりません。

どなたかご教授の程よろしくお願い致します(>_<)

-------------------------------------------------------------...続きを読む

Aベストアンサー

エラーの理由はNo2さんが回答していますので.....
Dir()関数は入れ子にできないのでフォルダの取得とファイルの取得を別々に考えます。
まずフォルダのみを収集しそのフォルダ内のファイルを取得します。

例:(見やすくするために全角スペースでイデントしています)
Sub test2()
 Dim buf As String
 Dim fName As String
 Dim msg As String
 Dim AA() As String
 Dim i As Long

 'フォルダの取得
 ReDim AA(0)
 buf = Dir("*.*", vbDirectory)
 Do While buf <> ""
  If GetAttr(buf) = vbDirectory Then
   If buf <> "." And buf <> ".." Then
    ReDim Preserve AA(UBound(AA) + 1)
    AA(UBound(AA)) = buf
    Cells(UBound(AA), 3) = buf
   End If
  End If
  buf = Dir()
 Loop

 'ファイルの取得
 For i = 1 To UBound(AA)
  fName = Dir(CurDir & "\" & AA(i) & "\" & "*.jpg")
  Do While fName <> ""
   cnt = cnt + 1
   Cells(cnt, 1) = AA(i)
   Cells(cnt, 2) = fName
   msg = msg & buf & "\" & fName & vbCrLf
   fName = Dir()
  Loop
  MsgBox msg
 Next i

End Sub

エラーの理由はNo2さんが回答していますので.....
Dir()関数は入れ子にできないのでフォルダの取得とファイルの取得を別々に考えます。
まずフォルダのみを収集しそのフォルダ内のファイルを取得します。

例:(見やすくするために全角スペースでイデントしています)
Sub test2()
 Dim buf As String
 Dim fName As String
 Dim msg As String
 Dim AA() As String
 Dim i As Long

 'フォルダの取得
 ReDim AA(0)
 buf = Dir("*.*", vbDirectory)
 Do While buf <> ""
  If GetAttr(buf) = vbDirecto...続きを読む

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

QVBAでフォルダ内の全てのcsvファイルからコピペ

マクロ超初心者です。

フォルダ内のすべてのcvsファイル(500程度)の5列目(500行程度)を新規ファイルの1列目から順にコピーしていきたいのです。

ちなみに元のcvsファイルのシート数は一つだけでシート名には全てファイル名が付いています。
(つまり全てのファイルのシート名が異なる)

見よう見真似で似たようなマクロから意味もわからないまま
つぎはぎして下記作りましたが
やっぱり動きません。

どなたか詳しい方どうかよろしくお願いします。


Sub Sample()
Const FolderPath As String = "C:\data"
Dim objFSO As Object
Dim objBook As Object
Dim lngRow As Long

Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objBook In objFSO.GetFolder(FolderPath).Files
lngcolumn = ThisWorkbook.Sheets("sheet1").Range("A" & Columns.Count).End(xlToRight).Column + 1
Workbooks.Open objBook.Path
With ActiveWorkbook
.Worksheets(1).Column("5").Copy ThisWorkbook.Sheets("sheet1").End(xlToRight).Offset(0, 1)
.Close
End With
Next

Set objFSO = Nothing

Application.ScreenUpdating = True

End Sub

マクロ超初心者です。

フォルダ内のすべてのcvsファイル(500程度)の5列目(500行程度)を新規ファイルの1列目から順にコピーしていきたいのです。

ちなみに元のcvsファイルのシート数は一つだけでシート名には全てファイル名が付いています。
(つまり全てのファイルのシート名が異なる)

見よう見真似で似たようなマクロから意味もわからないまま
つぎはぎして下記作りましたが
やっぱり動きません。

どなたか詳しい方どうかよろしくお願いします。


Sub Sample()
Const FolderPath As String = ...続きを読む

Aベストアンサー

私なら、こんな感じで作ります。

Sub test()
Const FolderPath As String = "C:\data"
Dim Filename As String
Dim Sh0 As Worksheet, Sh As Worksheet
Dim c As Long

Set Sh0 = ActiveSheet
Filename = Dir(FolderPath & "\*.csv")
Do Until Filename = ""
c = c + 1
Set Sh = Workbooks.Open(FolderPath & "\" & Filename).Sheets(1)
Sh.Columns(5).Copy Sh0.Columns(c)
Application.DisplayAlerts = False
Sh.Parent.Close
Application.DisplayAlerts = True
Filename = Dir()
Loop
End Sub

私なら、こんな感じで作ります。

Sub test()
Const FolderPath As String = "C:\data"
Dim Filename As String
Dim Sh0 As Worksheet, Sh As Worksheet
Dim c As Long

Set Sh0 = ActiveSheet
Filename = Dir(FolderPath & "\*.csv")
Do Until Filename = ""
c = c + 1
Set Sh = Workbooks.Open(FolderPath & "\" & Filename).Sheets(1)
Sh.Columns(5).Copy Sh0.Columns(c)
Application.DisplayAlerts = False
Sh.Parent.Close
...続きを読む

QExcel VBAで同じフォルダ内のファイルを開くには?

Windows2000、Excel2000を使用しています。

「経理」というフォルダに「見積」「請求」の2つのExcelファイルがあります。
「見積」から「請求」を開くマクロを作りたいのですが、どうすればいいでしょうか?
「経理」フォルダは場所が変わることがあるので、パスをどうすれば良いかがわからず苦しんでいます。
VBAはまったくの素人で、本を見ながら挑戦しているのですがうまくできないのです。

どうかよろしくお願いします。

Aベストアンサー

必ず「経理」というフォルダに「見積」「請求」の2つのExcelファイルがあると仮定。

以下ならどうでしょう?

フォルダごと移動されても上記のお約束があれば大丈夫と思います。
以下の記述は「見積」に記述してください。



Sub BookOpen()
Workbooks.Open Filename:=ThisWorkbook.Path & "\請求.xls"
End Sub


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング