Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

名前を変えてファイルをコピー

 既存のファイルを、名前を変えてクローン・ファイルを作るものです。

 このマクロをダウンロードできます。FileNameChangeCopy.xls

Option Explicit

Sub ファイル名変更コピー()

    Dim ファイル名 As String
    Dim 出力フォルダパス As String
    Dim 出力ファイル名 As String
    Dim 出力件数 As Integer
    Dim 開始日時 As Variant
    Dim 終了日時 As Variant

    開始日時 = Now
    ファイル名 = Trim(Range("B4").Value) & Trim(Range("B5").Value)
    出力フォルダパス = Trim(Range("C4").Value)

    If 出力フォルダパス = "" Then
        出力フォルダパス = Trim(Range("B4").Value)
    End If

    出力件数 = 0
    Do
        出力件数 = 出力件数 + 1

        出力ファイル名 = Range("C5").Cells(出力件数, 1)

        If 出力ファイル名 = "" Then Exit Do 'ファイル名が無いところで終わる。

        出力ファイル名 = 出力フォルダパス & 出力ファイル名

        FileCopy ファイル名, 出力ファイル名
    Loop

    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

 解説:

 FileCopy ステートメントを使って、ファイルをコピーします。
 既存ファイルと、変更後のファイルそれぞれ、フルパスで指定します。

 FileCopy source, destination

source 必ず指定します。コピーするファイル名を示す文字列式を指定します。フォルダ名およびドライブ名を含めて指定できます。
destination 必ず指定します。コピー後のファイル名を示す文字列式を指定します。フォルダ名およびドライブ名を含めて指定できます。

注:
 既に開いているファイルに対して、FileCopy ステートメントを実行しようとすると、エラーが発生します。


 Exit ステートメントは、Do...Loop ループ、For...Next ループ、Function、Sub、または Property の各プロシージャを抜けるフロー制御ステートメントです。


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの指定ファイルだけを、別のフォルダにそのままコピー

 既存のファイルを、指定したファイルだけを、別のフォルダにコピーするものです。

 このマクロをダウンロードできます。FileCopyVBA00.xls

Option Explicit

Sub 別のフォルダにそのままコピー()

    Dim 既存フォルダパス As String
    Dim コピー先フォルダパス As String
    Dim 既存ファイル名 As String
    Dim 出力ファイル名 As String
    Dim 出力件数 As Integer
    Dim 開始日時 As Variant
    Dim 終了日時 As Variant

    開始日時 = Now
    既存フォルダパス = Trim(Range("B4").Value)

    If Right(既存フォルダパス, 1) = "\" Then
      既存フォルダパス = Left(既存フォルダパス, Len(既存フォルダパス) - 1)
    End If

    コピー先フォルダパス = Trim(Range("C4").Value)

    If コピー先フォルダパス = "" Then
      MsgBox "コピー先が指定されていません!"
      Exit Sub
    ElseIf Right(コピー先フォルダパス, 1) = "\" Then
      コピー先フォルダパス = Left(コピー先フォルダパス, Len(コピー先フォルダパス) - 1)
    End If

    出力件数 = 0

    Do
        出力件数 = 出力件数 + 1

        既存ファイル名 = Range("B5").Cells(出力件数, 1).Value

        If 既存ファイル名 = "" Then Exit Do 'ファイル名が無いところで終わる。

        出力ファイル名 = コピー先フォルダパス & "\" & 既存ファイル名 'フルパスにする
        既存ファイル名 = 既存フォルダパス & "\" & 既存ファイル名     'フルパスにする

        FileCopy 既存ファイル名, 出力ファイル名
    Loop

    終了日時 = Now
    MsgBox "ファイル数 " & Str(出力件数) & " をコピーしました。" & vbNewLine _
    & "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダのサブ・フォルダの構成ファイルも含めて、
指定拡張子のファイルを、拡張子を変更してコピー

 別項の「フォルダ内のファイルを検索」は、指定フォルダ直下のファイルだけを、対象にしています。
 ここでは、FileSystemObject を使用して、フォルダ内のすべてのサブ・フォルダ を再帰的に探索して、処理対象にしています。

 このマクロは、下記を参考にしました。
Hey, Scripting Guy! : フォルダとそのサブフォルダ内のファイルの一覧を取得することはできますか
https://gallery.technet.microsoft.com/scriptcenter/93706e43-8c0a-4190-9c2c-ada05ef8667b
再帰を使用したサブフォルダの列挙
https://gallery.technet.microsoft.com/scriptcenter/39273856-c605-4e10-8580-6e733bd16add

 作った目的は、「UWSCの落し物部屋」のサンプル部分
http://siromasa.digi2.jp/uwsc/u_sample/
を、参照しやすくするためです。

 「UWSCの落し物部屋のサンプル」は、サンプル・ファイルの拡張子が、「uws」のため、リンクをクリックすると、ファイルをダウンロードしに行きます。
 ファイルをそのまま使う場合は、ダウンロードすることでよいのですが、プログラムを参照する目的では、ファイルの内容が、ブラウザ画面で直接表示されたほうが、便利です。

 このため、私は、Website Explorer を使って、上記サイトの全てのファイルを、私のパソコンに、一括ダウンロードしました。
 そして、サンプル・ファイルを、この Excelマクロを使って、拡張子を「uws」から「txt」に変換してコピーしました。
 さらに、ローカルの、List.html を以下のように加工しました。
1.正規表現置換で、(<a href=.*.uws">)を、\1ダウンロード</a> \1 に。
これで、<a href="./DLL/Class_Box.uws">が、
以下のようになります。
<a href="./DLL/Class_Box.uws">ダウンロード</a> <a href="./DLL/Class_Box.txt">

2.正規表現置換で、\.uws">$ を .txt">に。
3.普通の置換で、.uws</a> を .txt</a> に、.uws [Treasure]</a> を .txt [Treasure]</a> に。

 これで、私のパソコン上では、リンクをクリックすると、期待通り、ブラウザで、UWSのプログラムが、画面表示されるようになりました。

 このマクロをダウンロードできます。→FileRenameCopy.xls

 注:処理の途中でログを出力するバージョンも、参照下さい。


Option Explicit

'機能:指定フォルダの全ての下位構成の指定拡張子のファイルを拡張子を変更してコピーする

Dim ファイル_システム_オブジェクト As Object
Dim フォルダ_オブジェクト As Object

Dim サブフォルダ As Variant
Dim ファイル As Variant

Dim フォルダパス As String
Dim ファイル名 As String
Dim 変更前拡張子 As String
Dim 変更後拡張子 As String
Dim 処理フォルダ As String
Dim 拡張子 As String
Dim ファイルフルパス As String

Dim 開始秒 As Single
Dim 開始日時 As Variant
Dim 終了日時 As Variant


Sub 処理を起動()

    開始日時 = Now                ' 開始時刻を変数に格納します。

    ThisWorkbook.Worksheets("Sheet1").Activate
    フォルダパス = Range("B5").Value
    変更前拡張子 = Range("B6").Value
    変更後拡張子 = Range("B7").Value
    
    Set ファイル_システム_オブジェクト = CreateObject("Scripting.FileSystemObject")
    Call フォルダを次々調べて拡張子を変更コピー(ファイル_システム_オブジェクト.getfolder(フォルダパス))

    終了日時 = Now
    MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
    & Format(終了日時 - 開始日時, "nn分ss秒") & " でした。"

End Sub


Private Sub フォルダを次々調べて拡張子を変更コピー(Folder)
    For Each サブフォルダ In Folder.SubFolders
        処理フォルダ = サブフォルダ.Path
        
        Set フォルダ_オブジェクト = ファイル_システム_オブジェクト.getfolder(処理フォルダ)
        For Each ファイル In フォルダ_オブジェクト.Files
            ファイル名 = ファイル.Name
            拡張子 = ファイル_システム_オブジェクト.GetExtensionName(ファイル名)
            ファイルフルパス = ファイル.Path

            If 拡張子 = 変更前拡張子 Then
                FileCopy ファイルフルパス _
                , Left(ファイルフルパス, Len(ファイルフルパス) - 3) & 変更後拡張子
            End If
        Next
        
        Call フォルダを次々調べて拡張子を変更コピー(サブフォルダ)
    Next
End Sub

 解説:

 Fileオブジェクトは、ファイルのあらゆるプロパティにアクセスする手段を提供します。
http://msdn.microsoft.com/ja-jp/library/cc428069.aspx

プロパティ内容
Attributes プロパティファイルまたはフォルダの属性を設定します。値の取得も可能です。属性によっては、値の取得のみ可能な場合もあります。
DateCreated プロパティ指定されたファイルまたはフォルダの作成された日付と時刻を返します。値の取得のみ可能です。
DateLastAccessed プロパティ指定されたファイルまたはフォルダが最後にアクセスされたときの日付と時刻を返します。値の取得のみ可能です。
DateLastModified プロパティ指定されたファイルまたはフォルダが最後に更新されたときの日付と時刻を返します。値の取得のみ可能です。
Drive プロパティ指定されたファイルまたはフォルダが格納されているドライブの名前を返します。値の取得のみ可能です。
Name プロパティ指定されたファイルまたはフォルダの名前を設定します。値の取得も可能です。
ParentFolder プロパティ指定されたファイルまたはフォルダが格納されているフォルダを表す Folder オブジェクトを返します。値の取得のみ可能です。
Path プロパティ指定されたファイル、フォルダ、またはドライブのパスを返します。
ShortName プロパティ8.3 形式のファイル名が必要なプログラムのために、短いファイル名を返します。
ShortPath プロパティ8.3 形式のファイル名が必要なプログラムのために、短いパス名を返します。
Size プロパティファイルの場合、指定されたファイルのバイト単位のサイズを返します。フォルダの場合、指定されたフォルダ内のすべてのファイルおよびフォルダの合計サイズをバイト単位で返します。
Type プロパティファイルまたはフォルダの種類に関する情報を返します。たとえば、名前が .TXT の拡張子で終わるファイルの場合なら、"テキスト文書" という文字列が返されます。

メソッド内容
Copy メソッド指定したファイルまたはフォルダを別の場所にコピーします。
Delete メソッド指定されたファイルまたはフォルダを削除します。
Move メソッド指定されたファイルまたはフォルダを別の場所へ移動します。
OpenAsTextStream メソッド指定したファイルを開き、開いたファイルの読み取り、または追加書き込みに使用できる TextStream オブジェクトを返します。

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダの内容を丸ごとコピー

 フォルダ内容を、一式コピーするときに、使います。
 下記のマクロを使うと、Excelファイルと同レベルのフォルダをコピーします。


Sub フォルダをコピー()
    Dim ファイルシステムオブジェクト As Object           ' FileSystemObject
    Dim コピー元フォルダ As String
    Dim コピー先フォルダ As String
    Dim 現在のパス As String

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    現在のパス = ActiveWorkbook.Path

    コピー元フォルダ = 現在のパス & "\元フォルダ名"             ' 元フォルダ(配下の全サブフォルダ)
    コピー先フォルダ = 現在のパス & "\先フォルダ名"             ' 先フォルダ

    ' FSOによるフォルダコピー
    ファイルシステムオブジェクト.CopyFolder コピー元フォルダ, コピー先フォルダ, True

    '同じ名前のファイルが「コピー先」のフォルダ内に既にある場合、
    '「上書きするかどうか」に真 (True) を指定していると、既存ファイルは上書きされます。

    Set ファイルシステムオブジェクト = Nothing

End Sub

 解説:
 CopyFolder メソッドは、フォルダを別の場所へコピーします。

  FileSystemObject オブジェクト .CopyFolder コピーするフォルダsource , コピー先destination [, 既存フォルダを上書きするかどうか ]

 「コピーするフォルダ」にはワイルドカード文字を使えます。
 「コピー先」にはワイルドカード文字を使えません。
 例:
 FileSystemObject.CopyFolder "c:\mydocuments\letters\*", "c:\tempfolder\"

 引数 source にワイルドカード文字を指定した場合、または引数 destination がパスの区切り文字 (\) で終わる場合は、引数 destination に既存フォルダを指定したと判断され、条件に一致するフォルダおよびサブフォルダがそのフォルダ内へコピーされます。
 それ以外の場合では、引数 destination には、作成するフォルダの名前を指定したと判断されます。
 いずれの場合も、フォルダのコピーで実行される可能性のある処理は 4 種類あります。 引数 source でワイルドカード文字を使って指定したフォルダが、どのフォルダとも一致しない場合も、エラーが発生します。

CopyFolder メソッドは、最初のエラーが発生した時点で処理を中止します。エラーが発生するまでに行った処理を取り消したり元に戻したりする処理は一切行われません。


この種類の目次に戻る↑ 索引へ↓ トップページに戻る


指定フォルダを削除

 ローレベル・コード設定(その2)は、NTFSをデータベース管理システムとして使います。
 フォルダに、何万点ものファイルを入れたものをエクスプローラから削除しようとすると、削除操作に時間がかかります。
 下記のマクロを使うと、速く削除できます。

 下記のマクロは、削除したいフォルダを、A2 以下のセルに登録しておきます。
 そして、このExcelファイルを、削除したいフォルダと同一レベルに登録して、マクロを起動します。


Sub フォルダを削除()
    Dim ファイルシステムオブジェクト As Object           ' FileSystemObject
    Dim 削除フォルダ名 As String
    Dim 削除フォルダ As String
    Dim 現在のパス As String
    Dim カウンタ As Integer

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    現在のパス = ActiveWorkbook.Path
   Worksheets("Sheet1").Activate
   削除フォルダ名 = Range("A2").Value
   カウンタ = 1
   
   Do While 削除フォルダ名 <> ""
   
      削除フォルダ = 現在のパス & "\" & 削除フォルダ名
      
      ' FSOによるフォルダ削除
      On Error Resume Next
      ファイルシステムオブジェクト.DeleteFolder 削除フォルダ, False
      'Trueを指定すると読み取り専用ファイルも削除されます。省略するとFalseとみなされます。

      カウンタ = カウンタ + 1
      削除フォルダ名 = Range("A2").Cells(カウンタ, 1).Value
   Loop
   
   Set ファイルシステムオブジェクト = Nothing
   MsgBox "フォルダ削除を終わりました。"

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


フォルダを作成

 Excelシートに列記した名前で、フォルダを作るマクロです。
 この、マクロのExcelブックが保存してあるフォルダの配下に、サブ・フォルダとして作成します。
 この例では、作りたいフォルダ名は、このマクロのExcelブックの、シート名「管理シート」の、セル「B11」以下に登録してあります。


Sub フォルダ作成()
   Dim 現在のパス As String
   Dim フォルダ名 As String
   Dim 処理行 As Integer
   Dim 最終行 As Integer
   
   ThisWorkbook.Worksheets("管理シート").Activate
   現在のパス = ThisWorkbook.Path
   
   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   For 処理行 = 11 To 最終行
      フォルダ名 = 現在のパス & "\" & Range("B1").Cells(処理行, 1).Value
      If Dir(フォルダ名, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
         MkDir フォルダ名
      End If
   Next 処理行
End Sub

 解説:
MkDir ステートメント は、新しいフォルダを作成します。

構文
MkDir path

 引数 path は必ず指定します。引数 path には、作成するフォルダ名を示す文字列式を指定します。
ドライブ名も含めて指定できます。ドライブ名を省略したときは、現在のドライブに新しいフォルダが作成されます。
 既に存在するフォルダを作成しようとすると、エラーになります。
 上位の階層フォルダまでさかのぼって、フル・パスでフォルダを作ってくれる分けではありません。(単独のフォルダを作成するだけです。)

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ファイル名を変更

 Win32 API のヘルプ chm を作る過程で必要になったので、作成しました。
 Excel マクロと同一フォルダにあるファイルのファイル名を変更します。
 変更後のファイル名が既存の場合は、処理を飛ばします。

 このマクロをダウンロードできます。ChangeFileNameVBA02.xls


Option Explicit

'02:2012/03/23:カウンタを追加

   Dim 旧ファイル名 As String
   Dim 新ファイル名 As String
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 現在のパス As String
   Dim カウンタ As Integer
   

Sub ファイル名変更()

   ThisWorkbook.Worksheets("Sheet1").Activate
   現在のパス = ActiveWorkbook.Path
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   カウンタ = 0
   
   For 処理行 = 2 To 最終行
   
      旧ファイル名 = 現在のパス & "\" & Trim(Range("A1").Cells(処理行, 1).Value)
      新ファイル名 = 現在のパス & "\" & Trim(Range("B1").Cells(処理行, 1).Value)
      
      If Dir(新ファイル名) = "" _
      And Dir(旧ファイル名) <> "" Then '新ファイル名が存在せず、旧ファイル名が存在する場合
         Name 旧ファイル名 As 新ファイル名
         カウンタ = カウンタ + 1
      End If
   
   Next 処理行
   
   MsgBox "指定ファイル数 " & CStr(最終行 - 1) & " 中、" _
   & CStr(カウンタ) & " 件のファイル名を、変更しました。"

End Sub

 解説:
 Name ステートメント は、ファイルまたはフォルダの名前を変更します。
 構文
 Name oldpathname As newpathname
 Name ステートメントの構文は、次の指定項目から構成されます。
指定項目内容
oldpathname 必ず指定します。名前を変更するファイル名を示す文字列式を指定します。
フォルダ名およびドライブ名も含めて指定できます。
newpathname 必ず指定します。新しいファイル名を示す文字列式を指定します。
フォルダ名およびドライブ名も含めて指定できます。
引数 newpathname には、既に存在しているファイル名は指定できません。

 Name ステートメントはファイル名を変更して、必要に応じて他のフォルダにファイルを移動します。
Name ステートメントでは、ドライブ間ではファイルを移動しますが、newpathname と oldbathname で指定したドライブ名が同じ場合は、単に既存のフォルダの名前を変更します。
ファイルやフォルダを新しく作成することはありません。
 現在、開いているファイルに対して Name ステートメントを実行すると、エラーが発生します。ファイル名を変える前に、開いているファイルを閉じてください。
引数 Name には、複数の文字を指定するためのアスタリスク (*) および単一の文字を指定するための疑問符 (?) のワイルド カード文字を指定できません。

 次の例は、Name ステートメントを使って、ファイルの名前を変更します。
この例では、指定するフォルダは既に存在するものと仮定します。

Dim OldName, NewName
OldName = "OLDFILE": NewName = "NEWFILE"    ' ファイル名を定義します。
Name OldName As NewName                ' ファイル名を変更します。

OldName = "C:\MYDIR\OLDFILE": NewName = "C:\YOURDIR\NEWFILE"
Name OldName As NewName                ' ファイルの移動と名前の変更を行います。

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


複数ブックのシートを1つのブックにコピーする

 moug モーグ の下記に、複数のブックのシートを、一つのブックにコピーして集約するマクロを紹介していただいています。
http://www.moug.net/tech/exvba/0060003.html

 ただ、このマクロは、〜Excel 2003 と Excel 2007〜 が混在する環境では下記のエラーが表示されて動きませんでした。
移動先またはコピー先のブックの行列数が元のブックの行列数よりも少ないため、
シートを移動先またはコピー先のブックに挿入できません

http://www.officelabo.net/excel_qa/qa60.html
http://lifeworker.jp/excel/2013/06/11/4808.html

このため、クリップ・ボードを使ってコピーするバージョンを作ってみました。

いままでのVBAコードが動かないのはなぜ?
http://park.geocities.jp/tryvba/excel2007question.html
'  wb.Sheets("Sheet1").Cells.Copy ThisWorkbook.Sheets("特定").Cells

このマクロをダウンロードできます。→PluralBooksCopyToOneBookVBA01.xls

Option Explicit
Option Base 1

Sub 複数ブックのシートを1つのブックにコピーする()

   Dim 対象シート As Worksheet
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 処理Book As Workbook
   Dim ファイル名 As String
   Dim ワークブック As Workbook
   Dim シート数 As Integer
   Dim ファイル形式 As String
   Dim 出力ブック名 As String


   開始日時 = Now                ' 開始時刻を変数に格納します。

   ThisWorkbook.Worksheets("Sheet1").Activate
   出力ブック名 = Range("A11").Value

   '集約する貼付け先のワークブックを作成
   Set ワークブック = Workbooks.Add

   シート数 = 0

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set フォルダ = ファイルシステムオブジェクト.GetFolder(ThisWorkbook.Path)

   '★マクロのExcelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files
'      Stop
      ファイル名 = ファイル.Path

      If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "xls" Then

         If Dir(ファイル名) <> ThisWorkbook.Name Then '自分自身(マクロのブック)は対象外

            Set 処理Book = Workbooks.Open(Filename:=ファイル名) 'ブックを開く

             ' 処理Bookのすべてのワークシートを、集約先ブックに登録します。

             For Each 対象シート In 処理Book.Worksheets
               シート数 = シート数 + 1
               If シート数 > 1 Then
                  ワークブック.Worksheets.Add _
                  after:=ワークブック.Worksheets(ワークブック.Worksheets.Count)
               End If

               'シート名をコピー
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Name = 対象シート.Name
               '全てのセルを選択してコピー
               対象シート.Cells.Copy

               '貼付け先シートに貼り付ける
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Activate
               'Paste するためには、Activate が必要
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Paste
               'A1セルを選択して、全セル選択の状態を解除する
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Range("A1").Select

             Next

             処理Book.Application.CutCopyMode = False
             'クリップボードに大きな情報があります。この情報をほかのプログラムに貼り付けられるようにしますか?
             'を表示させない

             処理Book.Close savechanges:=False           '保存せずにブックを閉じる

            Set 処理Book = Nothing

         End If
     End If

   Next '★ファイル

   'シートをコピーしたブックを、名前を付けて保存。拡張子を xls にするために工夫が必要。
'   http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201001/10010042.txt

   ワークブック.SaveAs _
   Filename:=ThisWorkbook.Path & "\" & 出力ブック名 & Format(Date, "yyyymmdd") & ".xls", _
   FileFormat:=xlWorkbookNormal 'Excel ブック形式

   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing
   Set ワークブック = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る