ベストアンサー

フォルダ名をだすには

2008/11/14 16:08

以下のコードでファイル名一覧がだせる。しかしフォルダ名がでないフォルダ名をだすには、どうすればいいか。　sub　macro1（） Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub

taktta
お礼率72% (1031/1430)

オフィス系ソフト
回答数6
ありがとう数5

みんなの回答 （6）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

imogasi
ベストアンサー率27% (4737/17068)

2008/11/15 00:22 回答No.6

下記で動きましたが。 Target = CurDir Set bk = appexcel.Workbooks.Open(CurDir & "\" & "Book7.xls") の部分はテストしやすいように我流ですから、適当に変えてください。エクセルを立ち上げていない ForEachで繰り回す必要があるなど質のコードには不足しているのでは。ーーー ub macro1() Target = CurDir MsgBox CurDir Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Subfolders i = 1 Set appexcel = CreateObject("Excel.Application") Set bk = appexcel.Workbooks.Open(CurDir & "\" & "Book7.xls") For Each fx In Fil 'MsgBox fx.Name 'サブフォルダ名 sFile = fx.Name 'サブフォルダ名の書き出し bk.Sheets(1).Cells(i, "B") = sFile 'ファイル種別 sFType = fx.Type '最終更新日時の書き出し bk.Sheets(1).Cells(i, "C") = sFType '最終更新日 sLMod = fx.DateLastModified bk.Sheets(1).Cells(i, "D") = sLMod i = i + 1 Next bk.Close Set bk = Nothing Set appexcel = Nothing End Sub

質問者

お礼 2008/11/17 14:56

意図したものが出力できました。非常に感謝いたします。

その他の回答 (5)

hallo-2007
ベストアンサー率41% (888/2115)

2008/11/14 19:11 回答No.5

お詫びに、コードの最後に（End Sub と Nextの間に） Set Fil = Fol.Subfolders For Each Fx In Fil 'サブフォルダ名 sFile = Fx.Name 'サブフォルダ名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next を入れて同じ内容をフォルダーに対して実行してみて下さい。今、試してみました。

質問者

お礼 2008/11/17 14:58

動作を確認できました。どうもありがとうございます。

hallo-2007
ベストアンサー率41% (888/2115)

2008/11/14 18:58 回答No.4

No2,No3です。質問を勘違いしていました。 No1の方のアドバイス参考にしてください。指定したディレクトリに中にあるサブフォルダの名前を取得したいのですね。すみません。スルーしてください。

hallo-2007
ベストアンサー率41% (888/2115)

2008/11/14 18:50 回答No.3

あれれ？コードをそのままコピィして sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile の場合　B列に　Book1.xls　と出たのが sFile = Fx.Path 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile にしたら C:\Windows\mydoc\Book1.xls ^^^^^^^^^^^^^^^^^ と出たのですが、この事ではなかったのでしょうか。ちなみに、 ThisWorkbook.Sheets(1).Cells(i, 6) = Fx.Path 一行入れてもF列に出ましたが。 >このような情報はどうやったら得られますかまぐれです。

hallo-2007
ベストアンサー率41% (888/2115)

2008/11/14 16:46 回答No.2

試しにと思って sFile = Fx.Name　を sFile = Fx.Path　に変えたらパスとファイル名が出ますね。 MID関数使ってパスだけにするとかは如何でしょうか？でもこの場合　フォルダ名は　Targetでは MsgBox Target で表示されるのはご希望のこととは違いますか。

質問者

お礼 2008/11/14 18:20

回答どうもありがとうございます。しかし sFile = Fx.Name　を sFile = Fx.Path　に変えたらパスとファイル名が出ますね。とありますが実験してもフォルダ名はでてきませんが、本当にでたのでしょうか。 For Each Fx In Fil ' sFile = Fx.Path　 '名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type ということですよね。

質問者

補足 2008/11/14 18:05

sFile = Fx.Name　を sFile = Fx.Path　このような情報はどうやったら得られますか

mt2008
ベストアンサー率52% (885/1701)

2008/11/14 16:26 回答No.1

コード中の↓で、対象フォルダ内のファイル情報をFilにセットしていますよね。 Set Fil = Fol.Files サブフォルダの情報は、このコードで言えば　Fol.Subfolders ですので、ファイルと同様にセットしてファイル情報を書き出しているのと同様にループを回して書き出します。

質問者

お礼 2008/11/17 15:04

適切なコメントありがとうございました。おかげで解決しました。

関連するQ&A

エクセルでサイズ名の一覧を出したい
現在、下記のコードでフォルダ内のデータベースを作成しています。これに、『ファイルのサイズ』を加えたいのですが、何処に何を入れれば良いかがよくわかりません。どなたか回答出来る方がいらっしゃれば、宜しくお願いします。《現在使用しているコード》 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("一覧").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub
- ベストアンサー
- オフィス系ソフト
ファイルの一覧を作成する
お世話になります。ファイルの一覧を作成するマクロを作っていますが、拡張子を表示させないようにしたいのですが ”オブジェクトが必要です”とエラー出てなかなかうまくいきません。どなたか助けてください。 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = FS.GetBaseName(sFile.Name) 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub 'ファイル名 sFile = FS.GetBaseName(sFile.Name)の部分で ”オブジェクトが必要です”とエラーが出ます。
- ベストアンサー
- Excel（エクセル）
Excelマクロ　最後に画像を貼付けたい…
Excelにファイル名、情報、画像を表示するマクロを作成したいといろいろ探し、以下の参考マクロを探しました。 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub 　あと、最後の"F列"にファイル名の画像を貼付けたいのですがどのようにしたら良いのでしょうか？教えてください。
- ベストアンサー
- Visual Basic
画像のプロパティー書き出し
Excelに画像(例：001.bmp)のプロパティー情報の書き出し方を教えてください。 "全般"タブの書き出し方はだいたい調べて解りました。＊下記コード参考 "概要"タブの書き出し方がわかりません。下記のように入力するにはどうしたら良いのでしょうか？教えてください。＊参考コード＊ ThisWorkbook.Sheets(1).Range("A1") = "パス" ThisWorkbook.Sheets(1).Range("B1") = "ファイル名" ThisWorkbook.Sheets(1).Range("C1") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D1") = "最終更新日" ThisWorkbook.Sheets(1).Range("E1") = "フルパス" ～省略～ ThisWorkbook.Sheets(1).Cells(i, 1) = Target 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod 'フォルダフルパス SFull = Target & "\" & sFile ThisWorkbook.Sheets(1).Cells(i, 5) = SFull
- ベストアンサー
- Visual Basic
Excel VBA 別ブックへの登録
お世話になります。今お仕事でExcelのVBAで同じフォルダ内の別ブックにデータを書き込みたくていろいろやって見たのですが、上手くできません。お力を頂ければと・・・・＜詳細＞やりたいことサーバー内に各個人の見積フォルダがあり、そのフォルダの中に見積作成と見積データの各ファイルが2つあります。見積作成で作成したデータが登録ボタン（VBA）により見積データに登録されるようにしたい。今までは同じブック内の別シートへデータを登録していました。今回は同じフォルダ内の別ファイルへのデータ登録です。ここまではできました・・・・ Sub 見積データ取得() Dim wSheet As ThisWorkbook Dim idx As String 'データ保存用シートを取得 Workbooks.Open Filename:=ThisWorkbook.Path & "見積データ.xls" Set wSheet = ThisWorkbook.Sheets(見積作成.xls) '空白行を取得 idx = CStr(wSheet.UsedRange.Row(wSheet.UsedRange.Rows.Count).Row + 1) '明細を取得 Dim wRange As Range Set wRange = ThisWorkbook.Sheets("見積作成").Range("B7:Q175") Dim i As Integer For i = 1 To wRange.Rows.Count If wRange.Cells(i, 6).Value <> "" Then '作成日 wSheet.Range("A" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H2").Value '見積NO wSheet.Range("B" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H5").Value '見積名 wSheet.Range("C" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C1").Value '提出先NO wSheet.Range("D" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("B3").Value '提出先 wSheet.Range("E" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C3").Value '提出先フリガナ wSheet.Range("F" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("Y5").Value '担当者 wSheet.Range("G" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H1").Value '備考欄 wSheet.Range("S" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C31").Value 'メーカー名 wSheet.Range("H" & idx).Value = wRange.Cells(i, 10).Value '商品NO wSheet.Range("I" & idx).Value = wRange.Cells(i, 1).Value '商品名 wSheet.Range("J" & idx).Value = wRange.Cells(i, 2).Value '入数 wSheet.Range("K" & idx).Value = wRange.Cells(i, 9).Value '数量 wSheet.Range("L" & idx).Value = wRange.Cells(i, 3).Value 'A価 wSheet.Range("M" & idx).Value = wRange.Cells(i, 5).Value '金額 wSheet.Range("N" & idx).Value = wRange.Cells(i, 6).Value 'C価 wSheet.Range("O" & idx).Value = wRange.Cells(i, 14).Value 'D価 wSheet.Range("P" & idx).Value = wRange.Cells(i, 16).Value '数量 'wSheet.Range("K" & idx).Value idx = CStr(CInt(idx) + 1) End If Next でも上手くいきません・・・よろしくお願いいたしますm(_ _)m
- 締切済み
- SE・インフラ・Webエンジニア
フォルダ内全ファイルからデータを取得する方法
お力をお貸しください。下記のようなコードを書きました。*ドライブにあるフォルダ内全ファイルからデータを取得して、一つの表にまとめようとしています。が、Workbooks.Open sFileで、「ファイルが存在しません」というエラーがでます。変数を確認しましたが、きちっと呼び込んでいるのに、ファイルが存在しないとなるのが分かりません。ここで、データの最終行を取得するのに、ややっこしいコードを書いているのは、データが虫食い状態で、全部のセルが埋まっているのはC列しかないため、このようなことになっています。よろしくお願いします。 Sub Macro1() Dim FName As String, FPath As String, cnt As Long, r As Long, m As Long, MyMonth As String Dim LastRows As Long Set Wsh = CreateObject("Wscript.Shell") Set Wsh = Nothing m = Range("A1").Value - 1 MyMonth = m & "月" FPath = "*:\" & MyMonth & "\" ChDir FPath FName = FPath & "*.xls" sFile = Dir(FPath 　& "*") ' 画面更新オフ Application.ScreenUpdating = False With ThisWorkbook.Sheets(1) LastRows = Cells(Rows.Count, 1).End(xlUp).Row + 1 Do While sFile <> "" If sFile <> ThisWorkbook.Name Then Workbooks.Open sFile cnt = Cells(Rows.Count, 3).End(xlUp).Row + 1 ActiveSheet.Range("A1:" & "M" & cnt).Copy Destination:=ThisWorkbook.Sheets(1).Cells(LastRows, 1) ActiveWorkbook.Close SaveChanges:=False sFile = Dir() End If Loop End With '画面更新オン Application.ScreenUpdating = True ''名前をつけて保存 ' ' Application.DisplayAlerts = False ' Filedate = Format(Date, "yyyymm") ' ActiveWorkbook.SaveAs Filename:=FPath & "\" & Filedate & ".xls" ' Application.DisplayAlerts = True ' ''画面更新オン 'Application.ScreenUpdating = True ' ' End Sub
- ベストアンサー
- Visual Basic
Next,End Withのエラー
Sub 入力() If Sheets("入力").Range("D3").Value = "" Then MsgBox "客先名を入力して下さい" Else Dim K最終行 As Long Dim T最終行 As Long Dim i As Integer With Sheets("入力") For i = 3 To 12 If .Cells(i, "H").Value <> "" Then U最終行 = Sheets("注文書").Range("G65536").End(xlUp).Row + 1 If U最終行 = 461 Then MsgBox "注文書がいっぱいです" Exit Sub Else End If E最終行 = Sheets("営業確認").Range("G65536").End(xlUp).Row + 1 Sheets("営業確認").Range("k" & E最終行).Value = .Cells(i, "b").Value Sheets("営業確認").Range("b" & E最終行).Value = .Cells(i, "c").Value Sheets("営業確認").Range("c" & E最終行).Value = .Cells(i, "d").Value Sheets("営業確認").Range("d" & E最終行).Value = .Cells(i, "e").Value Sheets("営業確認").Range("g" & E最終行).Value = .Cells(i, "h").Value Sheets("営業確認").Range("f" & E最終行).Value = .Cells(i, "i").Value Sheets("営業確認").Range("i" & E最終行).Value = .Cells(i, "m").Value Sheets("営業確認").Range("h" & E最終行).Value = .Cells(i, "p").Value Else End If Select Case .Cells(i, "o").Value Case "北" K最終行 = Sheets("北").Range("h65536").End(xlUp).Row + 1 Sheets("北").Range("B" & K最終行).Value = .Cells(3, "C").Value Sheets("北").Range("c" & K最終行).Value = .Cells(3, "b").Value Case "中" T最終行 = Sheets("中").Range("H65536").End(xlUp).Row + 1 Sheets("中").Range("b" & T最終行).Value = .Cells(3, "c").Value Sheets("中").Range("c" & T最終行).Value = .Cells(3, "b").Value End Select Exit Sub Dim Dummy As Worksheet Dim SheetName As String Dim OTA As Long Dim GEN As Long Dim SheetName2 As String With Sheets("入力") '3行目～22行目まで For j = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, 14).Value 'もしシートがあれば・・・ If Err.Number = 0 Then 'SheetName2は入力シートのN行 SheetName2 = .Cells(i, 14).Value OTA = Sheets(SheetName2).Range("B65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("A7").Value = .Cells(3, "D").Value Sheets(SheetName2).Range("C3").Value = .Cells(3, "C").Value Sheets(SheetName2).Range("B" & OTA).Value = .Cells(i, "H").Value Sheets(SheetName2).Range("I" & OTA).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("F" & OTA).Value = .Cells(i, "K").Value Sheets(SheetName2).Range("H" & OTA).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("J" & OTA).Value = .Cells(i, "M").Value 'シートが無ければ・・・ Else GEN = Sheets("原紙").Range("B65536").End(xlUp).Row + 1 Sheets("原紙").Range("A7").Value = .Cells(3, "D").Value Sheets("原紙").Range("C3").Value = .Cells(3, "C").Value Sheets("原紙").Range("B" & GEN).Value = .Cells(i, "H").Value Sheets("原紙").Range("I" & GEN).Value = .Cells(i, "I").Value Sheets("原紙").Range("F" & GEN).Value = .Cells(i, "K").Value Sheets("原紙").Range("H" & GEN).Value = .Cells(i, "L").Value Sheets("原紙").Range("J" & GEN).Value = .Cells(i, "M").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName Next End With Exit Sub On Error GoTo 0 Sheets("原紙").Select Range("C3:E3,A7,B16:B35,F16:F35,H16:J35").Select Range("H35").Activate Selection.ClearContents Sheets("入力").Select Sheets("入力").Range("D3,G3:J12,L3:M12").Value = "" Sheets("入力").Range("D3").Select Range("B3").Formula = "=IF(D3="""","""",VLOOKUP(D3,'\\Seika-sv01\支店共有\マーケティング用\[担当者リスト.xls]リスト形式'!$B:$D,3,FALSE))" MsgBox "入力が完了しました" End If End Sub 上記のようにマクロを組みましたがエラーが出てしまいます。
- 締切済み
- その他（プログラミング・開発）
ｅｘｃｅｌ　　ｖba　　シートの取り扱い
Sub 　　aaa() Worksheets.Add ActiveSheet.Name = "Namefile" （(質問)ここへ適当なコードを追加することによって以下のThisWorkbook.Sheets(1)というのを、上で追加した Namefileシートを処理することとしたい。つまり　　Namefileシート＝ThisWorkbook.Sheets(1) どうすればいいか。よろしくお願いします。） ThisWorkbook.Sheets(1).UsedRange ThisWorkbook.Sheets(1).UsedRange.Delete ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "最終更新日" End Sub
- ベストアンサー
- オフィス系ソフト
マクロでのワイルドカードの使い方について
マクロ初心者です！下記の動きを実現したいです。 (1)ファイル「*あいう*」(※)の「シート#1」のF5→AE24までの値をコピー →上記の値をすべて加算し、「貼り付け先ファイル」のF5→AE24に貼り付け ※「某フォルダ」に存在する、ファイル名に「あいう」を含むすべてのファイル(ファイル数は可変)が対象 (2)上記を同様の動きを、範囲のすべてのセルでなく、 (F25:F42)、(H25:H42)、、～(AD25:AD42)と1列ごとに対して行う方々で知識のある方からご助力いただき、下記の「それっぽい」記述までは辿り着いたのですが、上手く動かず。。また、(1)と(2)は1つにできるのでは？とも推測してますが、どのように書けば間違いないのかわからない状況です…！知識のある方から、間違いや改善点などご教示いただけたらとてもうれしいです。 Sub (1)() Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(5, 6), Cells(24, 31)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd swb1.Close False End Sub Sub (2)() （(1)と同じ宣言） Dim c As Integer folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) For c = 6 To 30 Step 2 adr = Range(Cells(25, c), Cells(42, c)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Next swb1.Close False End Sub
- ベストアンサー
- Visual Basic
ワイルドカードを用いたセルの値加算&貼り付け
こんにちは！下記動きを実現したく、他の質問で方々からご教示いただいた内容をヒントに下記マクロを組んでみたのですが、実現したい動きになりませんでした。。知識のある方がいらっしゃれば、間違いを指摘いただけると嬉しいです！＜実現したい動き＞このファイルの貼り付け先シートのRange(Cells(6, 5), Cells(32, 30))に、下記条件を満たす全ての値を加算のうえ、ペーストする。「指定フォルダ」に格納されている、ファイル名に「あいう」を含むファイル(※)の、「指定シート」のRange(Cells(6, 5), Cells(32, 30))に存在する値 ※「あいう」の前後は不一致OK。複数存在し、ファイル数は可変。＜下記マクロを動かした結果＞該当ファイルは複数格納されているが、そのうちの1ファイルのみの値がコピペされている。 Sub マクロ() ' Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String Dim c As Integer folder = "C:\Users\指定フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート#1") Range(Cells(6, 5), Cells(32, 30))=0 sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(6, 5), Cells(32, 30)).Address(0, 0, 1) swb1.Sheets("あいう").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Application.CutCopyMode = False swb1.Close False End Sub
- ベストアンサー
- Visual Basic

フォルダ名をだすには