締切済み

VBAでぺージ設定を継承するファイル分割の方法

2011/05/26 16:49

エクセルファイルの分割方法について教えてください。使用OS等：Windows XP、Excel2003 具体的には1ブック、1シートのみに全データが入っています。項目行は2行あり、分割のキーと項目がA列に入っています。そのキー毎に新しいファイルを作りたいと考えています。始めに新しいファイルにパスワードをつけるかどうか、つけるならつけたいパスワードを入力するようなフォームが立ち上がります。そして、分割したい元ファイルはどれなのか選択式になっており、いろいろなファイルに適応できるような物にしています。尚、元ファイルの入っているフォルダ内に分割された各々のファイルを作成します。分割後のファイルには、”キー（XXX)+元ファイル名”にし、ページ設定や書式なども継承するようにしたいのですが、今使っているものですと、ページ設定が繁栄されません。ほとんど初心者なもので、元々あったマクロを少し修正したりはしているのですが、上記の問題を解決する事ができず、困っております。使用中のコードを載せますので、アドバイスまたは違う方法がありましたら、ご教示願います。コメントなどつけていただけるとありがたいと思います。どうぞよろしくお願い致します。 Sub 分割パスあり() Dim DPath As String Dim DName As String Dim fNAME As String Dim fiNAME As String Dim pass As String Dim oneNAME As String Dim oneFILE As String Dim opdia Dim n UserForm1.Hide pass = InputBox("パスワードを入力して下さい。", "パスワード入力") opdia = Application.Dialogs(xlDialogOpen).Show If opdia = Cancel Then Exit Sub End If DPath = ActiveWorkbook.Path & "\" DName = ActiveWorkbook.Name Range("A:A") = Range("A:A").Value Range("A3").Select Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess Selection.EntireRow.Insert shift:=xlShiftDown n = 4 For n = 4 To ActiveCell.CurrentRegion.Rows.Count * 2 On Error GoTo ErrorHandler If Cells(n, 1).Value = Cells(n - 1, 1).Value Then Else fNAME = Cells(n - 1, 1).Text fiNAME = fNAME & DName Rows("1:2").Copy Workbooks.Add ActiveSheet.Paste ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass Windows(DName).Activate Cells(n, 1).EntireRow.Insert shift:=xlShiftDown Cells(n - 1, 1).CurrentRegion.EntireRow.Select Selection.Copy Windows(fiNAME).Activate ActiveSheet.Paste Destination:=Range("A3") Cells.Columns.AutoFit ActiveWorkbook.Close savechanges:=True Windows(DName).Activate n = n + 1 End If Next oneNAME = Cells(n, 1).Text oneFILE = oneNAME & DName FileCopy Source:=fiNAME, Destination:=oneFILE Rows("1:2").Copy Workbooks.Add ActiveSheet.Paste ActiveWorkbook.SaveAs Filename:=DPath & oneFILE, password:=pass Windows(DName).Activate Cells(n, 1).CurrentRegion.EntireRow.Select Selection.Copy Windows(oneFILE).Activate ActiveSheet.Paste Destination:=Range("A3") Cells.Columns.AutoFit ActiveWorkbook.Close savechanges:=True Application.CutCopyMode = False Application.DisplayAlerts = False Windows(DName).Close savechanges:=False MsgBox "分割処理が終了しました" Exit Sub ErrorHandler: ActiveWorkbook.Close savechanges:=False Windows(DName).Close savechanges:=False MsgBox "分割処理が終了しました" Exit Sub End Sub

m-piglet
お礼率100% (3/3)

オフィス系ソフト
回答数3
ありがとう数4

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

みんなの回答

ap_2
ベストアンサー率64% (70/109)

2011/05/31 17:55 回答No.3

僕のミスです。確認してないのバレましたね（苦笑） '---> 変更後　'元シートを新しいブックとして複製　ActiveSheet.Copy 　ActiveSheet.Cells.Clear 　ActiveSheet.Range("A1").Select　'★A1を選択　'新しいブックを保存　ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass 　'1,2行目をコピペ　WorkBooks(DName).Activate 　ActiveSheet.Rows("1:2").Copy 　WorkBooks(fiNAME).Activate 　ActiveSheet.Paste 　WorkBooks(DName).Activate '<--- ★の1行が必要です。「新しいブックを開く」から「シートコピー＞"新しいブック"」の操作に置き換えました。2箇所とも差し替えちゃってください。印刷設定をコピーした以外はほぼ同じですが、複製したブックにはシートがひとつしかないので、必要に応じてSheets.Addを。あと、ANo.1のはエラーになります。エラー発生時に正常っぽく終了しちゃうのは混乱を招くので、変えておくとよさそうです（※On Error GoTo ErrorHandlerで、エラーダイアログを出さず "ErrorHandler:" のラベルまで処理を飛ばしてます）＠後から3行目　MsgBox "分割処理に失敗しました" VBEでは、F8キーで（メニュー＞デバッグでも）コードを１行ずつ実行できます。ローカルウィンドウを開いておけば、変数の中身も覗けちゃいます。便利ですし、理解の助けにもなるので、試しに使ってみてください。ちなみに、質問文はそんなもんだと思いますよ（笑）。要領よく聞けるなら解決できるでしょうし、足りない部分はコードが補ってくれます。こーいうトコにあがるコードは読み辛いのも当たり前ですが、全部読むワケじゃないので。ええ、だから失敗するんですが…今度は動くかな（－－；

質問者

お礼 2011/06/11 16:47

ap2様、体調不良のためお休みしていたので、お礼が遅くなってしまい、大変申し訳ございません。再度、ご回答くださり本当にありがとうございました。早速、試してみようと思います。ご丁寧なフォロー、感謝致します。本当に嬉しいです！

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

2011/05/27 22:13 回答No.2

コード例が長くて、質問の意図が判りにくい。「継承」などと難しい言葉を使っているが、プログラムのプロですか。ーーー質問は、エクセルシートをコピーしたとき、コピーで出来た（コピーされた）シートに、ページ設定の設定を効き告ぎたい引継ぎたい。それも、ＶＢＡコードでということですか。シートをコピーしても、コピー元のページ設定項目は引き継がれないようだ。シートのセルの値や、書式や、コメント、入力規則、数式など以外のものは、移らないようだ。何か１行（２－３行）で別シートのＰａｇｅＳｅｔＵｐの項目（多数あり）を代入するような方法はＰａｇｅＳｅｔＵｐオブジェクトにはないようだ。だから設定可能項目は、ページ設定のマクロの記録で判るので、そのそれぞれの項目に対しＢシートＰａｇｅＳｅｔＵｐ項目＝ＡシートＰａｇｅＳｅｔＵｐ項目（内容は値（数値・文字列・Ｆａｌｓeなど）でしょう）を項目ごとに繰返さないとならないようだ。ーーシート数が多いとコピーの時間がかかるという質問 http://www.keep-on.com/excelyou/2000lng4/200005/00050060.txt ２０１０で変化があったようだ http://kinuasa.wordpress.com/category/office%E9%96%A2%E9%80%A3/ 同様の質問？ http://okwave.jp/qa/q6273710.html ーーもし上記のような質問なら質問のコード例など無関係では。

質問者

お礼 2011/05/30 12:44

imogasi様　お返事遅くなり申し訳ありません。長いコードの貼り付けや、継承などという言葉を使ってしまい、気分を害してしまったら大変申し訳ありません。私はプロどころか、本当にマクロを勉強し始めたばかりの素人同然で、既存で使ってあったものを修正して作れるのなら・・・との思いで質問させていただきました。どうやらちょっとした修正だけという訳にはいかないようですね・・・。上記提示していただいた同様の質問などを参考に考えたいと思います。

ap_2
ベストアンサー率64% (70/109)

2011/05/27 12:22 回答No.1

セルのコピーを繰り返して処理しているようですが、ページ設定(印刷関係)はシートの情報なので、セルのコピーでは写すことができません。今回は目的が複製っぽいので、新しいファイルを生成する際に、シートをコピーして作るのが良さそうです。試しに書いてみました。動くか分りませんが… '---> 変更前 ' Rows("1:2").Copy ' Workbooks.Add ' ActiveSheet.Paste ' ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass ' Windows(DName).Activate '<--- '---> 変更後　'元シートを新しいブックとして複製　ActiveSheet.Copy 　ActiveSheet.Cells.Clear 　'新しいブックを保存　ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass 　'1,2行目をコピペ　WorkBooks(DName).Activate 　ActiveSheet.Rows("1:2").Copy 　WorkBooks(fiNAME).Activate 　ActiveSheet.Paste 　WorkBooks(DName).Activate '<--- Sheets.Copyは、挿入位置を指定しなければ、そのシートひとつだけの「新しいブック」を生成します。セルのデータごと複製されるので、Cells.Clearで一旦まっさらにします。これで、ページ設定を引き継ぎながら、WorkBooks.Addと同じことができます。ちなみに、ページ設定のプロパティをひとつずつ反映することもできますが、大変かと。参考程度に↓(※この中にプロパティがイッパイ入ってるよ！) 　Sheets.PageSetup がページ設定　Sheets.HPageBreaks が改ページ初心者とのことですが、記録機能でここまで作ったのか、他の人が作ったのか…、前者なら最初の数行で足りたかも知れませんね。余談ですが、慣れてきたら、Activateをやめると処理がすっきりしますよ。Workbooks("hoge.xls").Sheets("hoge").Copy のようにすれば、ActiveSheetを対象にしなくてもよくなるので。

質問者

お礼 2011/05/30 12:07

ap2 様、お返事送れて大変申し訳ありません。ご丁寧にご回答いただきありがとうございました。試しに教えていただいたコードに書き換えてみましたが、1つだけ全く空っぽのファイルが作成されただけ・・・という結果になってしまいました。 2箇所同じ箇所があって、2箇所とも変えてしまったのがわるかったのでしょうか・・・？しかしながら、ActiveSheetの件など、参考になりました。どうもありがとうございました。

関連するQ&A

VBA　シート指定とファイル名入力
部署ごとに分割し、ブックで保存するコードです。 sheet名は「部署」です。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 5 To w.Range("B65536").End(xlUp).Row s = w.Cells(r, "B") w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1, -1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = ActiveWorkbook.Path & "\1\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") w.Rows(2).Copy Range("A2") w.Rows(3).Copy Range("A3") w.Rows(4).Copy Range("A4") Resume Application.ScreenUpdating = True End Sub (1)sheet1にマクロ実行ボタンを配置し、部署seedにマクロ実行命令をする。 (2)sheet1のB2セルにファイル名を入力して、そのファイルに保存する。（例部署ファイル） (1)Dim w As Worksheets("部署")と変更したのですが、エラーが出ました。 (2)myPath = ActiveWorkbook.Path & "\部署ファイル\"　　↑ これをsheet1のB2セルから指定できるようにしたいです。宜しくお願いします。
- ベストアンサー
- Visual Basic
VBA　探しているFileがないときの処理方法
現在、下記のようにしてマクロ実行ブックと同じ階層のフォルダ名を取得してAに、フォルダ内のabc.XLSのC9の値をBに、abc.XLSの更新日時をCに表示させています。このとき、フォルダ内にabc.XLSが無い場合にファイル名をAに書き出してB及びCは空白というように表示したいのですが、どのようにすればよろしいでしょうか。 macro1は以前質問させて頂いたものがベースになっています。ExecuteExcel4Macroを使っている関係でファイル名が無いときの処理はDirを使ってできるとmougで調べてわかりましたが、自分の知識ではできず、macro2を作成したのですが、指定ファイルがない場合の処理がうまくできずにいます。 macro1はファイルオープンの窓が開きます。macro2はファイルが存在しないという窓が開きます。どちらの場合でもかまいませんのでお力をお貸し頂けませんでしょうか。 Sub macro1() Dim myPath As String Dim myFolder As String Dim r As Long r = 3 myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" Application.ScreenUpdating = False Range("A3:C60").Clear Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Cells(r, 1) = myFolder Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3") On Error Resume Next Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook) On Error GoTo 0 If Cells(r, 3) = "" Then Cells(r, 2) = "myBook" End If Cells(r, 2).NumberFormatLocal = "#,##0_ " Cells(r, 3).NumberFormatLocal = "y""年""m""月""" With Range("A3:C60") .Sort Key1:=Range("C3"), Order1:=xlAscending .Borders.LineStyle = True End With r = r + 1 End If End If myFolder = Dir() Loop Application.ScreenUpdating = True End Sub Sub Macro2() Dim myPath As String Dim myFolder As String Dim myBook As String myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" i = 2 Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Workbooks.Open (myPath & myFolder & "\" & myBook) Range("C9").Activate Selection.Copy ThisWorkbook.Activate Cells(i, 1) = myFolder Cells(i, 2).PasteSpecial xlValues Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook) Workbooks(myBook).Close SaveChanges:=False i = i + 1 End If End If myFolder = Dir() Loop End Sub
- ベストアンサー
- Visual Basic
ＶＢＡのコピー
ＶＢＡのコピー Dim xls As New Excel.Application Dim wbk As New Excel.Workbook Dim sh3 As Worksheet Set sh3 = Worksheets("全") sh3.Activate sh3.Range("A1:Z65536").Select Selection.Clear Set wbk = xls.Workbooks.Open("\\***.***.*.***\管理\全データ抽出.xls") wbk.Worksheets("全").Activate 'ワークシートをアクティブにする wbk.Worksheets("全").Range("A1:Z65536").Copy 'コピーする 'ActiveSheet.Paste Destination:=Worksheets("全").Range("A1") '貼り付ける Worksheets("全").Range("A1").PasteSpecial Paste:=xlPasteValues wbk.Close SaveChanges:=False 'Worksheets("メイン").Cells(1, 1).Select を実行すると　『wbk.Close SaveChanges:=False』のところでクリップボードに大きな情報があります。・・・・と言うメッセージがでて必ずとまってしまうのですがメッセージをでないようにしたいのですが教えてください。お願いします。
- ベストアンサー
- その他（プログラミング・開発）
VBA　複数の行を挿入後、挿入以外を削除
知恵をお借りください。 A10に5行分挿入、A13に2行分挿入、A14に1行分挿入、A16に2行分挿入以下がコードです。 Dim n As Long n = Worksheets("Sheet1").Range("A1").Value With Worksheets("Sheet2") .Range("A10").Resize(n).EntireRow.Insert .Range("A10").Resize(n).EntireRow.Interior.Color = vbYellow .Activate End With Dim k As Long k = Worksheets("Sheet1").Range("A2").Value With Worksheets("Sheet2") .Range("A13").Resize(n).EntireRow.Insert .Range("A13").Resize(n).EntireRow.Interior.Color = vbRed .Activate End With Dim m As Long m = Worksheets("Sheet1").Range("A5").Value With Worksheets("Sheet2") .Range("A14").Resize(n).EntireRow.Insert .Range("A14").Resize(n).EntireRow.Interior.Color = vbGreen .Activate End With Dim ka As Long ka = Worksheets("Sheet1").Range("A10").Value With Worksheets("Sheet2") .Range("A16").Resize(n).EntireRow.Insert .Range("A16").Resize(n).EntireRow.Interior.Color = vbBlue .Activate End With マクロ実行後、行の並び方がバラバラになっています。 ↓イメージ図 https://mega.nz/#!yUwXHTLK!TSZvMJ1CaiTi-OoX-1j9IeNleuXesrzU5O7o2vG-svI 理想図に整えるにはどうすれば良いのでしょうか？また、マクロで行を挿入したら、不要な行を削除するコードも教えてくださればありがたいです。 ↓イメージ図 https://mega.nz/#!fMRDAKAJ!GHMpiagpn-O_0aaMhrHOozFd8WHHkSQzOS-fSCInw-g 宜しくお願いします。
- ベストアンサー
- Visual Basic
エクセルVBA　CSVファイル出力について
エクセルVBAでCSVファイル出力マクロを作成しています。本を参考にして作成したのですが、日付のセルで 2007/7/22　8:29:45と記入させているのが #2007-07-22 08:29:45#と言う形で出力されてしまいます。そのまま「2007/7/22 8:29:45」と出力させるにはどのようにしたらいいのでしょうか？出力したデーターを基にアクセスに取り込んでデーターベースにしようと思っているのですが、「＃」があるため、そのまま、時刻関数で取り込めないもので困っています。コードは以下のように書いてあります。 Sub WriteCsv() Dim myTxtFile As String, myFNo As Integer Dim myLastRow As Long, i As Long Dim ShName As String Application.ScreenUpdating = False ShName = ActiveSheet.Name myTxtFile = ActiveWorkbook.Path & "\" & ShName & ".csv" myLastRow = Range("A1").CurrentRegion.Rows.Count myFNo = FreeFile Open myTxtFile For Output As #myFNo For i = 1 To myLastRow Write #myFNo, Cells(i, 1), Cells(i, 2), Cells(i, 3) Next Close #myFNo MsgBox "このシートを元に「" & ShName & ".csv」を作成しました" End Sub 宜しくお願いいたします。
- ベストアンサー
- オフィス系ソフト
VBAでCSVファイルを読み込もうとしていますが、
VBAでCSVファイルを読み込もうとしていますが、「ファイルが見つかりません」とエラーが表示されます。どのように対処していいのかわかりません。教えてくください。 Sub readCsv() Dim csvFile As String Dim ch As Integer Dim csvStr As String Dim str() As String Dim i As Integer Set ShellApp = CreateObject("Shell.Application") Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1) targetFolder = oFolder.Items.Item.Path Set fso = CreateObject("Scripting.FileSystemObject") Set fileList = fso.GetFolder(targetFolder).Files For Each file In fileList csvFile = file.Name ch = FreeFile Open csvFile For Input As #ch i = 1 Do While Not EOF(1) Line Input #ch, csvStr Close #ch str = Split(csvStr, ",") Range(Cells(i, 1), Cells(i, UBound(str) + 1)) = str i = i + 1 Loop Next End Sub
- ベストアンサー
- Visual Basic
'Range'メソッドは失敗しました
ExcelのVBAの質問になりますが、教えてください。下記を動かすと最後の行で「'Range'メソッドは失敗しました: '_Worksheet' オブジェクト」と出ますどうしても最後の行をセレクトしたいのですが、どうしたらよいでしょうか。 Option Explicit Public WB1 As Workbook Public WB1SH1 As Worksheet Public CSVWB1 As Workbook Public CSVWB1SH1 As Worksheet Dim MaxRow As Integer Private Sub CommandButton1_Click() Set WB1 = ActiveWorkbook Set WB1SH1 = WB1.Worksheets(1) Dim a As String a = WB1SH1.Range("a1) Workbooks.Open "C:\Users\User\Desktop\" & a & ".CSV" Set CSVWB1 = ActiveWorkbook Set CSVWB1SH1 = CSVWB1.Worksheets(1) MaxRow = CSVWB1SH1.Cells(Rows.Count, 1).End(xlUp).Row WB1SH1.Activate WB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select CSVWB1SH1.Activate CSVWB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select　　'←ここでエラーがでる End Sub
- ベストアンサー
- Excel（エクセル）
EXCEL、VBAについて
' GLOBAL変数の定義 Dim CurrentDir As String '現在のディレクトリ Dim ThisBook As String '現在のブック名 Dim WorkSheetName1 As String Dim WorkSheetName2 As String Dim ConfigSheetName As String Dim ListSheetName1 As String Dim ListSheetName2 As String Dim ListSheetName3 As String Dim ListSheetName4 As String Dim ListSheetName5 As String Dim ListSheetName6 As String Dim ListSheetName7 As String Dim ErrorFlag As Integer 'エラーフラグ　0:正常 1:エラー Sub 初期設定() CurrentDir = ActiveWorkbook.Path '現在のディレクトリ ThisBook = ActiveWorkbook.Name '現在のブック名 WorkSheetName1 = "work1" WorkSheetName2 = "work2" ConfigSheetName = "設定" ListSheetName1 = "****" ListSheetName2 = "****" ListSheetName3 = "****" ListSheetName4 = "****" ListSheetName5 = "****" ListSheetName6 = "****" ListSheetName7 = "****" Application.DisplayAlerts = False 'EXCELの警告を無視する End Sub Sub CSV取り込み() Dim LoadBook As String '読み込みブック名 Dim DataMaxCol As Integer '読み込みデータ有効最大カラム数 Dim WorkStartRow As Integer 'workシート開始行 Dim WorkEndRow As Integer 'workシート終了行 Dim ListMaxCol As Integer '一覧シート有効最大カラム数 Dim ListStartRow As Integer '一覧シート開始行 '初期設定コール Call 初期設定 'workシートをクリア DataMaxCol = Sheets(ConfigSheetName).Range("F2").Value WorkStartRow = Sheets(ConfigSheetName).Range("F3").Value WorkEndRow = Sheets(ConfigSheetName).Range("F4").Value Sheets(WorkSheetName1).Select Range(Cells(WorkStartRow, 1), Cells(WorkEndRow, DataMaxCol)).ClearContents '受注データファイルを選択しオープン SelectedPath = Application.GetOpenFilename("CSVファイル (*.csv), *.csv") If SelectedPath <> "False" Then Workbooks.Open Filename:=(SelectedPath) Else 'キャンセル時は終了 Exit Sub End If LoadBook = ActiveWorkbook.Name '現在のブック名 '受注データの開始行をチェック I = WorkStartRow '受注データの最終行をチェック Do Until ActiveCell.Value = "" I = I + 1 Cells(I, 1).Select Loop WorkEndRow = I - 1 '受注データをコピー Range(Cells(WorkStartRow, 1), Cells(WorkEndRow, DataMaxCol)).Select Selection.Copy 'workシートへペースト Windows(ThisBook).Activate Sheets(WorkSheetName1).Select Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False '受注データファイルをクローズ Windows(LoadBook).Close End Sub このマクロを実行するとインデックスが有効範囲にありませんとなりエラーとなってしまいます。あと最後のデータファイルをクローズできればOKなのですが・・。どこがいけないんでしょうか？
- ベストアンサー
- Visual Basic
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で対応できる方法があれば、ベストです。よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
vba　ファイルの移動について
フォルダAの中にあるたくさんのpdfファイルの中から、ファイル名の頭文字３つがE列に記載した「aaa」だったらフォルダBに移動させるという内容にしたいです。ネット検索などで、近いものを作成しましたが（下に貼り付け）、下から４行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で「実行時エラー'53'　　ファイルが見つかりません。」　とエラーが出てしまいます。どの様に書き直せばよいのでしょうか？どなたかご存じでしたら、ぜひお教え下さい。よろしくお願いします。エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName　'ここでストップ End If Next End Sub
- ベストアンサー
- Excel（エクセル）

VBAでぺージ設定を継承するファイル分割の方法