• 締切済み

【Excel VBA】ファイルにヘッダーを挿入

Excel VBAが初心者です、よろしくお願いします。 仕事で必要なため本を読みながら挑戦しております。 アドバイスをいただけると助かります。 【実現したいこと】 あるフォルダ内に格納された多くのファイルに、ヘッダーを挿入します。ヘッダー挿入後のファイルは、新ファイルで保存をします。 詳細は下記のとおりです。また、作りかけのプログラムも以下のとおりです。 【詳細】 ・あるフォルダ:0001tokyou、0002tokyou・・・1000tokyou・・・(数字4桁は固定+tokyou)というファイルが格納されております。ファイル数はそのときによって異なります。これらは拡張子が無いファイルですが、メモ帳で開くことができます。VBAではフォルダを選択できることとします。 ・ヘッダー:ヘッダーは1種類ですが、項目は10個あります。 ・新ファイル保存:ヘッダー挿入前のファイル「0001tokyou」にヘッダーを挿入したら、「0001kantou」という新しいファイルで保存します。従って、0001tokyouファイルは存在したままです。 【作りかけのプログラム】 Sub ヘッダ挿入と別名保存() Dim myFile As String Dim mydata As String Dim myArray() As String Dim fileName As String Dim folderName As String Dim i, j As Integer Dim header As Variant header = Array("氏名", "性別", "年齢", "生年月日", "住所", "マンション名", "備考1", "備考2", "備考3", "備考4") '挿入するヘッダーを定義する。 If Application.FileDialog(msoFileDialogFolderPicker).Show Then folderName = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) End If '加工するファイルが格納されているフォルダを指定する。 If folderName = "" Then MsgBox "フォルダが指定されませんでした。処理を終了します。", vbOKOnly Exit Sub End If '加工するファイルが格納されているフォルダが指定されなかった場合の処理です。 fileName = Dir(folderName & "\*") Do While fileName <> "" myFile = Workbooks.Open fileName:=folderName & "\" & fileName For i = 0 To 8 'ヘッダーを新ファイルに挿入する。 Cells(1, i + 1).Value = header(i + 1) Next i fileName = Dir() Loop End Sub アドバイスをいただけると助かります。 よろしくお願いします。

みんなの回答

  • hana-hana3
  • ベストアンサー率31% (4940/15541)
回答No.2

>これらは拡張子が無いファイルですが、メモ帳で開くことができます。 Workbooks.Open で開いても、エクセルファイルではないので、提示されたプログラムでは処理できません。 もちろん、セルもありませんから記入する事もできないはずですが? 一度、エクセルファイルをメモ帳で開いて見てください。 ヘッダーを入れて何をしたいのか解りませんが、テキストファイルを扱うプログラムにしないと無理だと思いますが? http://officetanaka.net/excel/vba/file/file08.htm http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110.html

coltcolt
質問者

補足

hana-hana3、教えていただいたURLを拝見させていただきました。 アドバイスありがとうございます。 >Workbooks.Open で開いても、エクセルファイルではないので、 >提示されたプログラムでは処理できません。 ⇒処理ができないことは知りませんでした。  Excelファイルであれば処理はできるのでしょうか。  0001tokyou.xls、0002tokyou.xls・・・1000tokyou.xls・・・(数字4桁は固定+tokyou.xls)というファイルに変更できます。  可能であれば、プログラムで示していただけると助かります。 >もちろん、セルもありませんから記入する事もできないはずですが? >一度、エクセルファイルをメモ帳で開いて見てください。 ⇒Excelファイルをメモ帳で開くと文字化けしてます。  拡張子がない今回のファイル(0001tokyou、0002tokyou・・・1000tokyou・・・(数字4桁は固定+tokyou)というファイル)を、Excelで開くと、セルに格納されております。 >ヘッダーを入れて何をしたいのか解りませんが、テキストファイルを >扱うプログラムにしないと無理だと思いますが? ⇒ヘッダーを入れる目的は、業務上必要な処理です。 自力で色々試しておりますが、アドバイスをいただけると助かります。

  • tom11
  • ベストアンサー率53% (134/251)
回答No.1

よく解りませんが、この操作は、手動でも 簡単に出来ることなのでしょうか??? もし、できるなら、自動マクロを利用したほうが 手っ取り早いです。 出来たマクロを参考に、改良すれば 良いかもしれません。

coltcolt
質問者

補足

tom11さん、ご意見ありがとうございます。 >よく解りませんが、この操作は、手動でも >簡単に出来ることなのでしょうか??? ⇒Excelのマクロ以外の方法でなら、手動でいくらか簡単に出来ます。   もし、できるなら、自動マクロを利用したほうが 手っ取り早いです。 出来たマクロを参考に、改良すれば 良いかもしれません。 ⇒Excelのマクロ以外の方法なので、マクロの記録で参照することはできません。 プログラミングを組むことで、僕以外の同僚が、この処理をできるようにすることが目的です。

関連するQ&A

  • ExcelVBA どこが間違えていますか?

    ExcelVBA 初心者です。 下記のようなプロシージャを人様の作ったのをコピーして作ったのですが意図したとおりになりません。どこが間違っているのか教えてください。 私の意図は選択したフォルダの中の全ファイル(Book)名をアクティブシートのA列に順番に表示したい、です。今は実行すると全部セルA1に表示されてしまって、最後の1つのファイル名しか分かりません。ファイルごとに別のセルに表示したいのです。よろしくお願いします。 Sub ファイル一覧() Dim foldername As String Dim filename As String Dim i As Integer Dim dlg_folder As FileDialog Set dlg_folder = Application.FileDialog(msoFileDialogFolderPicker) Folder_Dialog: dlg_folder.Show If dlg_folder.SelectedItems.Count <> 1 Then Exit Sub Else foldername = dlg_folder.SelectedItems.Item(1) MsgBox "選択したフォルダは " & foldername & " です。" filename = Dir(foldername & "\*.xls", vbNormal) If filename = "" Then MsgBox "Excelファイルがありません。" GoTo Folder_Dialog End If End If Set dlg_folder = Nothing Do While filename <> "" For i = 1 To Workbooks.Count Cells(i, 1).Value = filename i = i + 1 Next i filename = Dir() Loop MsgBox "フォルダ " & foldername & " の中のファイルはすべて表示されました。" End Sub あれ、なぜかインデントが無効になっています。

  • EXCEL→CSV形式で別ファイルに保存

    EXCELデータ内のある1つのシートのデータをそのまま別ファイル(CSV)に保存したいのですがうまくいかないので教えてください。 本を見ながらこのようなマクロを作ったところ、EXCEL(○○.xls)の指定したシート(keihi)のみをCSV形式で別フォルダ(C:\経費振替)に保存することができたんですが、 元のEXCELも、ファイル名称・形式がCSV(○○.xls→keihi.csv)に変わってしまいます。 エクセルのファイル名、形式は変えずにできる方法ってありますか?? Sub データはきだし() Dim Ret As String Dim Res As Integer Dim FolderName As String Set WK1 = Worksheets("1 依頼書") Set WK4 = Worksheets("keihi") FolderName = "C:\経費振替" Ret = Dir(FolderName, 16) If Ret = "" Then Res = MsgBox("DATA保管用フォルダを作成します。", vbYesNo) If Res = vbYes Then MkDir FolderName End If End If ' Dim Res2 As Integer Res2 = MsgBox("DATAを作成します。", vbYesNo) WK4.Select If Res2 = vbYes Then With WK4 .SaveAs Filename:=FolderName & "\keihi", FileFormat:=xlCSV ←多分ココが何か間違ってるのだと思うんですが。 End With

  • vba ハイパーリンクの値をテキストで取得したい

    Dim FolderName As String FolderName = rst![格納フォルダパス] ハイパーリンクの 「#」を抜いたテキストの値で取得したいのですが、 どうやったらいいですか?

  • vba ファイルの移動について

    フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字3つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが(下に貼り付け)、 下から4行目、「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

  • Excel2003のVBAでエクセルファイルとして保存

    こんにちわ。 Excel2003のVBAで、シート1に採点用のフォーマットを作成し、採点ボタンを押したら別の場所(フォルダ)に別のファイル(.xls形式)として採点結果を保存したいと考えています。過去に似たような質問があったのでそれを参考にしたのですが、コードの意味がほとんど分かりません。下記のコードで実行したところ、エラーが出てしまいます。どこが悪いのか教えていただけないでしょうか? エラー箇所は BkName = OldWkbook.Sheets(StName1).Range("K1").Value です。”インデックスが有効範囲にありません”と表示されます。 例)   Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "ko" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("K1").Value FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1)).Copy Set NewWkbook = ActiveWorkbook 'シートの保護を解除 Worksheets("sheet1").Unprotect For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除 NewWkbook.Sheets(1).Shapes(wIx).Delete '←1ではなくwIxです End If Next NewWkbook.Sheets(1).Name = StName1 ' FileName = "D:\保存\計画\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub

  • EXCEL2007のVBAを使って、テキストファイルを読み込んで別のテ

    EXCEL2007のVBAを使って、テキストファイルを読み込んで別のテキストファイルを作って書き込むというコードを書きましたが、新しく出来たテキストファイルの末尾に、もともとのファイルには無かったスペースが追加されてしまいます。 原因と対策を教えて頂きたいです。 ------------------------------------------------------- Dim FileName1 As String Dim FileName2 As String Dim FileNumber1 As Integer Dim FileNumber2 As Integer Dim Data As String FileName1 = Application.GetOpenFilename("Text Files (*.txt), *.txt") FileName2 = Application.GetSaveAsFilename(, "Text Files (*.txt), *.txt") Data = Space(FileLen(FileName1)) FileNumber1 = FreeFile Open FileName1 For Binary As #FileNumber1 Get #FileNumber1, , Data Close #FileNumber1 'この間に"Data"内容を処理するコードを入れる予定 FileNumber2 = FreeFile Open FileName2 For Binary As #FileNumber2 Put #FileNumber2, , Data Close #FileNumber2 ------------------------------------------------------- このコードで1284バイトのテキストを読み込ませると末尾にスペースが追加されて1918バイトになってしまいました。 "Data"の内容を表示させてもスペースはなく、Len関数で大きさを調べても1284バイトです。

  • VBAを使ってファイルを圧縮したい

    こんばんは。 他の方の質問ですが http://oshiete1.goo.ne.jp/qa2405614.html を参考にVBAでエクセルファイルの圧縮に挑戦しています。 しかしうまくいきません。 なのでご教授お願いします。 エクセルの標準モジュールに 下記のコードを載せました。 //////////////////////////////////////////////////////////////////////// 'Option Explicit Private Declare Function Zip Lib "Zip32j" (ByVal hWnd As Integer, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As Integer) As Integer Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Sub testZip() 'Zip32 による圧縮 Dim Filename As String Dim strArchiveName As String Dim strCommand As String Dim RC As Long Dim hWnd As Long Dim strOutPut As String * 512 Dim lngSize As Long 'ハンドル取得 hWnd = FindWindow("XLMANI", Application.Caption) 'ファイル名取得 Filename = myDeskTopPath & "\Book1.xls" If Filename = "False" Then Exit Sub Filename = Mid$(Filename, InStrRev(Filename, "\") + 1) strArchiveName = Mid$(Filename, InStrRev(Filename, "\") + 1, InStrRev(Filename, ".") - InStrRev(Filename, "\") - 1) & ".zip" strCommand = "-u " & strArchiveName & " " & Filename lngSize = Len(strOutPut) RC = Zip(hWnd, strCommand, strOutPut, lngSize) 'Debug.Print strOutPut End Sub Function myDeskTopPath() ' 実行時の デスクトップパス取得 Dim MyWSH As Object Set MyWSH = CreateObject("WScript.Shell") myDeskTopPath = MyWSH.SpecialFolders("Desktop") Set MyWSH = Nothing End Function //////////////////////////////////////////////////////////////////////// そして「Zip32j 」がないので http://www.vector.co.jp/soft/win95/util/se062163.html からダウンロードしました。 しかし、 「 RC = Zip(hWnd, strCommand, strOutPut, lngSize)」 の部分で、 「ファイルが見つかりません。 (Error 53)」 になります。 ダウンロードした「zip3j037」はフォルダごとデスクトップに置いています。 ただこれをダウンロードしただけではダメなのでしょうか? エラーの原因がわかりません。 よろしくお願いします。

  • vba, 複数ブックの同一セルに同一写真を挿入

    エクセルVBAの初心者です。使っているのはExcel2007です。 同じフォルダの中にある連番の複数のエクセルファイルに同じ操作を繰り返すマクロを作っています。まず、複数ブックの同一セルに同じ内容の文字列を挿入することはどこかで見つけました。 Sub 複数Book同一セルに同一文字列入力() Dim fName As Variant Dim i As Long Dim WB As Workbook fName = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xlsx", MultiSelect:=True) If IsArray(fName) Then For i = LBound(fName) To UBound(fName) Set WB = Workbooks.Open(fName(i)) WB.Worksheets(1).Range("A1").Value = "テスト" WB.Close SaveChanges:=True Next End If End Sub また、選択したセルに同じフォルダの中にある写真を挿入するマクロもどこかで拝見しました。 Sub AddPictureSampLinkPaste() Dim myFileName As String Dim myShape As Shape myFileName = ActiveWorkbook.Path & "\Koala.jpg" '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納 Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=myFileName, _ LinkToFile:=True, _ SaveWithDocument:=False, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする With myShape .ScaleHeight 1, msoTrue '数字は写真の高さの倍数 .ScaleWidth 1, msoTrue '数字は写真の幅の倍数 End With End Sub ここまではテストで問題なかったので、この二つのマクロを一つにまとめて、同じフォルダにある連番のエクセルブックの同一セルに同一写真を挿入するマクロを作ろうと下記のようにアレンジしましたが、なぜか写真はマクロを記入したブックのアクティブセルに連番のブックの数だけの写真が重なるように貼り付けられるだけで、標的のブックには写真が挿入できません。 Sub 複数Bookの同じ位置に同一写真挿入() Dim fName As Variant Dim i As Long Dim WB As Workbook Dim myFileName As String Dim myShape As Shape fName = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xlsx", MultiSelect:=True) myFileName = ActiveWorkbook.Path & "\Koala.jpg" If IsArray(fName) Then For i = LBound(fName) To UBound(fName) Set WB = Workbooks.Open(fName(i)) Worksheets("Sheet1").Activate '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納 Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=myFileName, _ LinkToFile:=True, _ SaveWithDocument:=False, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする With myShape .ScaleHeight 1, msoTrue .ScaleWidth 1, msoTrue End With WB.Close SaveChanges:=True Next End If End Sub 本当にどこが間違っているか分からず、ここで質問いたします。初心者で分からないところばかりなので、どなたかやさしく教えていただけませんか?よろしくお願いいたします。

  • VBAで複数のエクセルファイルを自動圧縮

    VBAで複数のエクセルファイルを自動圧縮 お世話になります。 以下サイトなどを参考にVBAでエクセルファイルの圧縮をさせようとしています。 ダイアログで圧縮したいファイルを指定して圧縮するところまではできました。 http://oshiete.hmv.co.jp/qa5155002.html ■やりたいこと 特定のフォルダにある複数のファイルを個別に圧縮して、それぞれzipファイルとしたい。 圧縮するファイルを指定するダイアログは出さずに、自動化したい。 ■VBAの記述 Dim Filename As String Dim strArchiveName As String Dim strCommand As String Dim RC As Long Dim hWnd As Long Dim strOutPut As String * 512 Dim lngSize As Long Dim strPassWord As String strPassWord = "pass" 'ハンドル取得 hWnd = FindWindow("XLMANI", Application.Caption) '★ファイル名取得★ Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls") If Filename = "False" Then Exit Sub Filename = Mid$(Filename, InStrRev(Filename, "\") + 1) strArchiveName = Mid$(Filename, InStrRev(Filename, "\") + 1, InStrRev(Filename, ".") - InStrRev(Filename, "\") - 1) & & ".zip" strCommand = "-uP " & strPassWord & " " & strArchiveName & " " & Filename lngSize = Len(strOutPut) RC = Zip(hWnd, strCommand, strOutPut, lngSize) ■質問  ファイル名を毎回変えて繰り返し処理すればいいと考えてますが、  圧縮するファイルを指定するダイアログを消すことができません。。。  ファイル名を以下のように直接指定しましたが、以下エラーが出てしまいます。  VBAで取得したファイル名で圧縮するような記述の仕方があればご教示いただけると助かります! '★ファイル名取得★ Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls") If Filename = "False" Then Exit Sub   ↓以下に変更したがエラー  Filename = "C:\" & "test.xls" ←とりあえずファイル名を固定で指定したつもり。。  ●イミディエイトに表示されるエラー   zip warning: name not matched: test.xls   zip warning: test.zip not found or empty

  • VBAによるエクセルデータの貼り付けについて

    会社で使用しているエクセルにボタンがあり、そのボタンを押すと指定したフォルダー内のファイルのデータをコピーし、貼り付けるようVBAコードが設定されています。 指定したファイルのデータを下記のどの部分でセルを指定しているのかを教えてください。 Sub 読込() Dim WorkFileNAME, FolderNAME, DBYear, DBMonth, ItemNO(45) As String Dim WorkSheetNAME As String Dim i As Integer Dim BASECelladd1, BASECelladd2 As String BASECelladd1 = "C4" BASECelladd2 = "D3" WorkFileNAME = ActiveWorkbook.Name WorkSheetNAME = ActiveSheet.Name Worksheets(WorkSheetNAME).Select FolderNAME = Range("J1").Value & "\" & Range("T1").Value DBYear = Range("D1").Value DBMonth = Range("E1").Value i = 0 Do While i <= 45 ItemNO(i) = Range(BASECelladd1).Cells(i + 1, 1).Value i = i + 1 Loop Data11READ WorkFileNAME, WorkSheetNAME, FolderNAME, DBYear, DBMonth, ItemNO, BASECelladd1, BASECelladd2 End Sub

専門家に質問してみよう