- 締切済み
質問させて頂きます。
質問させて頂きます。 マクロにて、特定フォルダ内の複数のxlsファイルを順次編集するため、 以下のコードを使用しています。 この度、"C:\第一営業部\"の下に、"C:\第一営業部\一課\"や、 "C:\第一営業部\三課\鈴木\"など、複数層のサブフォルダを増設し、従来通り "第一営業部"内のすべてのファイルを編集したいのですが、どのように記述を 変更すれば実現できるでしょうか？尚、上記の通り、サブフォルダの階層数は 一定ではありません。 お手数をおかけいたします。宜しくお願い申し上げます。 '--------------------------------------------------------- Dim fileNmCol As Collection 'ファイル名格納コレクション Dim folderPath As String 'フォルダのフルパス '作業用 Dim tempFileNm As Variant Dim fullPath As String Set fileNmCol = New Collection 'フォルダパス folderPath = "C:\第一営業部\" 'Dirにより、ファイル名を取得（xlsファイルのみ） 'フォルダ配下にあるファイル名を順次fileNmに格納する。 tempFileNm = Dir(folderPath + "*.xls", vbNormal) 'ファイル名をfileNmColに追加する Do While tempFileNm <> "" fileNmCol.Add (tempFileNm) tempFileNm = Dir() Loop 'ファイルの数だけ繰り返し For Each tempFileNm In fileNmCol 'ファイルのフルパスを設定指定して、Excelブックを開く fullPath = folderPath + tempFileNm Workbooks.Open fullPath '------------------------------------------------------- '（ここでファイルを編集する記述） '------------------------------------------------------- 'ファイルを閉じる（アラートを無効にする） Application.DisplayAlerts = False Workbooks(tempFileNm).Close Application.DisplayAlerts = True Next '-----------------------------------------------------------------
- copper11
- お礼率50% (1/2)
- Visual Basic
- 回答数2
- ありがとう数3
- みんなの回答 （2）
- 専門家の回答
関連するQ&A
- Excel VBAを用いた一括ファイル処理方法
Excelコマンドボタンを用いて、特定のフォルダ内に格納されたExcelファイルの一括処理をしたいのですが、おもうようにできません。 一括処理内容は、A列以外入力できないようにロックさせる処理になります。 （可能であればPW設定もつけたい。） いろいろサンプルコードやマクロの記録で繋げてみたのですが、おもうようにできません。 どうすればよいのか教えて頂きたく、どうぞよろしくお願いいたします。 ＜コード＞ Private Sub CommandButton1_Click() Dim fileNmCol As Collection 'ファイル名格納コレクション Dim folderPath As String 'フォルダのフルパス '作業用 Dim tempFileNm As Variant Dim fullPath As String Set fileNmCol = New Collection 'フォルダパス folderPath = "C:\TEST\" 'Dirにより、ファイル名を取得（xlsファイルのみ） 'フォルダ配下にあるファイル名を順次fileNmに格納する。 tempFileNm = Dir(folderPath + "*.xls", vbNormal) 'ファイル名をfileNmColに追加する Do While tempFileNm <> "" fileNmCol.Add (tempFileNm) tempFileNm = Dir() Loop 'ファイルの数だけ繰り返し For Each tempFileNm In fileNmCol 'ファイルのフルパスを設定指定して、Excelブックを開く fullPath = folderPath + tempFileNm Workbooks.Open fullPath Cells.Select Selection.Locked = False Selection.FormulaHidden = False Columns("I:I").Select Range(Selection, Selection.End(xlToLeft)).Select Columns("C:I").Select Range("I1").Activate Selection.Locked = True Selection.FormulaHidden = False ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _ False Range("A1").Select ActiveWorkbook.Save 'ファイルを閉じる（アラートを無効にする） Application.DisplayAlerts = False Workbooks(tempFileNm).Close Application.DisplayAlerts = True Next End Sub
- ベストアンサー
- その他(業務ソフトウェア)
- 印刷ダイアログを表示させない方法
いつもお世話になっております。 ExcelのVBAで印刷ダイアログを表示させないようにするにはどのようなプロパティを設定すればよいでしょうか。 以下のようなコードを作成しました。 Sub ファイルの印刷() Dim trgFolder As String Dim buf As String Dim sht As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False trgFolder = _ "C:\Documents and Settings\Name\My Documents\ファイル\" buf = Dir(trgFolder & "*.xls") Do While buf <> "" Workbooks.Open trgFolder & buf For Each sh In Worksheets With ActiveSheet .PageSetup.Zoom = 80 .PrintOut End With Next Workbooks(buf).Close buf = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub "ファイル"フォルダの各Excelファイルのすべてのシートを印刷するためのマクロです。 よろしくお願いします。
- 締切済み
- Visual Basic
- これのおかしいところはありますか？エクセル B列
Option Explicit Sub ExtractColumnB() Dim FolderPath As String Dim FileName As String Dim SourceWorkbook As Workbook Dim TargetWorkbook As Workbook Dim SourceWorksheet As Worksheet Dim TargetWorksheet As Worksheet Dim LastRow As Long Dim TargetLastRow As Long ' 対象フォルダの選択 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub FolderPath = .SelectedItems(1) End With ' 出力用ワークブックとワークシートを作成 Set TargetWorkbook = Workbooks.Add Set TargetWorksheet = TargetWorkbook.Worksheets(1) ' 対象フォルダ内のExcelファイルを順次処理 FileName = Dir(FolderPath & "\*.xls*") Do While FileName <> "" ' ソースファイルを開く Set SourceWorkbook = Workbooks.Open(FolderPath & "\" & FileName) Set SourceWorksheet = SourceWorkbook.Worksheets(1) ' B列のデータを抽出 LastRow = SourceWorksheet.Cells(Rows.Count, 2).End(xlUp).Row ' 抽出したデータを出力用ワークシートにコピー TargetLastRow = TargetWorksheet.Cells(Rows.Count, 2).End(xlUp).Row + 1 SourceWorksheet.Range("B1:B" & LastRow).Copy TargetWorksheet.Range("B" & TargetLastRow) ' ソースファイルを閉じる SourceWorkbook.Close SaveChanges:=False ' 次のファイルへ FileName = Dir Loop ' 確認メッセージ MsgBox "B列のデータ抽出が完了しました。", vbInformation End Sub
- 締切済み
- Excel（エクセル）
- フォルダ内の対象となるデータ名の個数
フォルダ内にある任意のデータ名の個数を数える エクセルのマクロを使って作成したいと思っています 任意のデータ名はA1セルに入力されている名前を使おうと思っています 以下にワイルドカードを使った場合のコードを貼っておきます。 Sub Sample2() Dim FolderPath As String Dim FileName As String Dim FileInt As Long Dim SetPath As String FolderPath = "C:\Users\ユーザ名\Desktop\データ" 'フォルダのパスを指定する FileName = "*.xlsm" 'ファイル名をワイルドカードと拡張を指定する FileInt = 0 'ファイル数を一度0にする '指定したフォルダパスとファイル名をセットする SetPath = Dir(FolderPath & "\" & FileName) Do While SetPath <> "" 'ファイル名が取得出来なくなるまでループ FileInt = FileInt + 1 SetPath = Dir() Loop MsgBox FileInt End Sub
- 締切済み
- Excel（エクセル）
- フォルダ内の特定ブックだけを1つのブックにまとめる
以前こちらで質問させて頂きましたフォルダ内の特定ブックだけを1にのブックにまとめる方法で、大変助かっていましたがブック名が変更になり、教えて頂いたマクロでは実行できなくなったので自分なりに考えたのですがどうしてもできません。 質問時のブック名は「1_****」と「2_****」で 今回「1_****」だけが「1(3)_****」に変更になりました。 下記のマクロでmyfile = dir(mypath & "1_" & "*.xl*")→myfile = dir(mypath & "1(3)_" & "*.xl*")に変更するのはわかるのですが do until myfile = "" myfile2 = "2" & mid(myfile,2,99)をどう変更すれば良いかわかりません どなたかお助け頂けませんか？ sub macro1() dim myPath as string dim myFile as string dim myFile2 as string mypath = "c:\test\" myfile = dir(mypath & "1_" & "*.xl*") do until myfile = "" myfile2 = "2" & mid(myfile,2,99) workbooks.open mypath & myfile workbooks.open mypath & myfile2 application.displayalerts = false workbooks(myfile).worksheets("2").delete application.displayalerts = true workbooks(myfile2).worksheets("2").move after:=workbooks(myfile).worksheets("1") workbooks(myfile).close true workbooks(myfile2).close false myfile = dir() loop end sub
- 締切済み
- オフィス系ソフト
- VBAでの行削除について
教えてください。 現在、VBAを使用して、CSVファイルの編集をしたいと考えています。 フォルダ内に数個のCSVファイルがあり、それらにすべて同じ処理（行削除など）をしたいのです。 下記のようなプログラムです。 Sub getting() Dim myPath As String Dim myFName As String Dim FCnt As Integer Dim A(500) As String MsgBox CurDir() Workbooks("自動処理.xls").Activate myPath = ActiveWorkbook.Path MsgBox myPath ChDir myPath FCut = 0 myFName = Dir("*.csv") If myFName <> "" Then FCut = FCut + 1 A(FCut) = myFName Do myFName = Dir() If myFName <> "" Then FCut = FCut + 1 A(FCut) = myFName MsgBox A(FCut) Else Exit Do End If Loop End If MsgBox "「" & myPath & "」には、" & FCut & "個のファイルがあります。" Dim i As Integer Dim seet As String Dim ws As Object Dim FullPath As String For i = 1 To 1 seet = Left(A(1), 6) FullPath = myPath & "\" & A(i) 'Workbooks.Open(FullPath).Activate Open FullPath For Append As #1 Print #1, Rows("1:1").Select Selection.Delete Shift:=xlUp Rows("2:2").Select Selection.Delete Shift:=xlUp Range("A1").Select Print #1, Range("A1").Value = "" Print #1, Range("A1").Value = "COMP_NAME" Print #1, Range("B1").Select Print #1, ActiveCell.Value; "PC_OS" Print #1, Range("C1").Select Print #1, ActiveCell.Value = "OS_SUB_VERS" Print #1, Range("D1").Select Print #1, ActiveCell.Value = "IP_ADDR" Print #1, Range("E1").Select Print #1, ActiveCell.Value = "LOCATION " Close #1 ' Workbooks(A(i)).Save ' Workbooks(A(i)).Close savechanges:=False Next i End Sub 教えていただきたいのは、どうにかworkbook.openを使わず、ファイルを編集できるところまでいったのですが、ファイルを開かずに行を削除することができません。 ＞Print #1, Rows("1:1").Select ＞Selection.Delete Shift:=xlUp ＞Rows("2:2").Select ＞Selection.Delete Shift:=xlUp ファイルを開かずに行削除をできるものなのでしょうか。 ご存知の方がいれば教えてください。 よろしくお願いいたします。
- 締切済み
- その他（プログラミング・開発）
- すべてのシートに同じ処理をするにはこれでいい？
フォルダ内にあるすべてのブックのすべてのシートに同じ処理をするマクロを書いたのですが思った動きをしてくれませんでした。 ちなみにやりたい事は!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!で囲まれたところだけ変えれば、シート数がバラバラな複数のブック内のすべてのシートで同じ処理が行われるようになる事です。 今回は複数のブックのA列を選択してコンマで区切るようにしています。 いろんなとこからコピペでつなぎ合わせたんですがどこがわるいんだろう？コンパイルはできてしまうのでどこを直せばいいのやら自力で見つけられません。お助けください。 環境はExcel2007 Windows7です。 Sub Allfile() Dim PATH As String Dim KTS As String PATH = Application.InputBox("編集したいファイルがあるフォルダのパスを入力。", "入力", Type:=2) KTS= Application.InputBox("編集したいファイルの拡張子を入力(ドットもいれる)。", "入力", Type:=2) Application.ScreenUpdating = False '画面の更新をしないようにして処理速度up Dim fileNmCol As Collection 'ファイル名格納コレクション Dim tempFileNm As Variant Dim fullPath As String Set fileNmCol = New Collection tempFileNm = Dir(PATH + "*KTS", vbNormal) 'Dirにより、ファイル名を取得フォルダ配下にあるファイル名を順次fileNmに格納する。 Do While tempFileNm <> "" 'ファイル名をfileNmColに追加する fileNmCol.Add (tempFileNm) tempFileNm = Dir() Loop For Each tempFileNm In fileNmCol 'ファイルの数だけ繰り返し ↓以下ブックごとの処理 fullPath = PATH + tempFileNm 'ファイルのフルパスを設定指定して、Excelブックを開く Workbooks.Open fullPath Dim Ws As Worksheet 'ワークシートの変数を用意 For Each Ws In Worksheets 'シートの数だけ繰り返し ↓以下シートごとに対する処理 Ws.Activate 'Ws.Activate」がないと、はじめのシートのみの実行となります。 '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True 'A1行を選択してコンマ区切りにする '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Next Ws Next Application.ScreenUpdating = True End Sub
- 締切済み
- その他（インターネット・Webサービス）
- VBAで新しい日付順にファイルを検索するには？
ExcelのVBA初心者です。 ファイルを新しい日付のものから順番に検索したいのですが、幾ら探しても分かりませんでした。どなたか教えていただけないでしょうか？ やりたいことは、あるフォルダ内に毎日5～6個のファイルが保存されていくのですが、その中の決められたセルに指定した文字列が含まれているもの3つ場合分けしてファイルを出力したいのです。 例えば、 ファイル名 セルE1の内容 日付 123.xls ”111111A” 6/29 15:39:40 456.xls ”111111N” 6/29 15:35:10 789.xls ”222222V” 6/29 15:20:43 654.xls ”222222A” 6/29 14:30:21 321.xls ”111111V” 6/29 14:10:33 951.xls ”222222N” 6/28 17:52:15 753.xls ”333333A” 6/28 17:30:50 とファイルがあり、セルE1に”111111”の文字列を含むファイルを検索し、 末尾に”V”があるもの → f(1)=321.xls 末尾に”N”があるもの → f(2)=456.xls 末尾に”A”があるもの → f(3)=123.xls と出力したいのです。 分からないなりに、いろいろ調べて切り貼りしながら作ってみました。 これで一応うまくいったのですが、検索する文字列は、必ず上記例のように新しい日付の5～6ファイルの中にあり、検索対象のフォルダ内には1000個以上ファイルがあります。 上記プログラムだと読み込む順番が最後になってしまいますので、恐ろしく処理時間が掛かってしまいます。 Sub ファイル検索() Dim buf As String, cnt As Long Dim i As Integer Dim wb(3) Dim bk As String, lot As String, lt As String Dim Path As String Application.ScreenUpdating = False lt = Cells(1, 5) bk = ActiveWorkbook.Name Path = Cells(1, 5) buf = Dir(Path & "*.xls") i = 1 Do While wb(1) = "" Or wb(2) = "" Or wb(3) = "" cnt = cnt + 1 Workbooks.Open Path & buf Select Case Cells(2, 5) Case Is = lt & "V" wb(1) = buf Case Is = lt & "N" wb(2) = buf Case Is = lt & "A" wb(3) = buf End Select Application.DisplayAlerts = False Workbooks(buf).Close Application.DisplayAlerts = True buf = Dir() Loop For i = 1 To 3 Workbooks(bk).Sheets(1).Cells(i, 1) = "wb(" & i & ")" & "=" & wb(i) Next i Application.ScreenUpdating = True End Sub 日付の新しいファイルから読み込む良い方法はないでしょうか？ Excelのバージョンは、2003です。 出来れば、2003～2010で対応できる方法があれば、ベストです。 よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
- 複数ファイルのA1だけを抽出して別ファイルにしたい
すみませんが、教えてください。 特定のフォルダ内に入っているcsvのA1列目のみ抽出して別ファイルにしたく、検索したところ 同じように困っていた方がいたようで、参考にさせていただいたのですが、 以下を実行しても インデックスが有効範囲にありませんと出ます。 各csvファイルのシート名は 1000近くあるファイル全て違い、別々の名前（コード00-000とか）になっています。 （エクセルで開いたとき） お手数ですが、教えていただきたくお願いいたします。 参考にしたマクロです。 Sub macro1() Dim myPath As String Dim myFile As String myPath = "ファイルの場所\" myFile = Dir(myPath & "*.xls") Do Until myFile = "" Workbooks.Open myPath & myFile With Workbooks("集約.xls").Worksheets("Sheet1").Range("A65536").End(xlUp) .Offset(1, 0).Value = myFile .Offset(1, 1).Value = Workbooks(myFile).Worksheets("概要").Range("C3").Value End With Workbooks(myFile).Close savechanges:=False myFile = Dir() Loop End Sub 宜しくお願いいたします。
- 締切済み
- SE・インフラ・Webエンジニア
- 指定フォルダ内のファイルオープン→別フォルダに同じファイル名のcsvとして保存 のマクロを作ろうとしています
エクセルで、指定フォルダ内のファイルオープン→別フォルダに同じファイル名のcsvとして保存 のマクロを作ろうとしています。 現在下記のようなマクロを途中まで作成したのですが、保存の良い方法が分からず困っております。 (ファイルオープンまでは出来ているようですが、その後エラーが出てしまいます） どなたかお知恵を拝借願えませんでしょうか。 どうぞ宜しくお願い致します。 Sub Book_Open() Dim BookName As String Dim PathName As String PathName = "C:\test_htmltocsv\test\" BookName = Dir(PathName & "*.html") Do Until BookName = "" Workbooks.Open PathName & BookName BookName = Dir() ActiveWorkbook.SaveAs "Sample.xls" ←← Loop End Sub
- 締切済み
- その他MS Office製品
お礼
お返事が遅くなり申し訳ありません。 早速のご回答、誠にありがとうございます。 指定部分を確認したのですが、小生のレベルが低いため、 どのように引用したらいいのかよく分かりませんでした・・・ 自分で、少々試してみます。