kotaexcel

[kotaexcel]

ファイルデータの転記

例えばExcelファイルをバージョンアップしたけど、それをあげる相手が、データの移行をきちんとできるか不安……というときに、ボタンを押せばデータを新しいバージョンに移せるという仕組みを作っておけば、楽ですよね。

と以前から思っていたので、今回はそれを作りました。

Sub sum_file_data() 'データを写す

   Application.ScreenUpdating = False

   Dim book_path As String, temp_book As Workbook

   ChDir ThisWorkbook.Path 'カレントフォルダを現在のブックのフォルダに

   book_path = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")    If book_path = "False" Then 'ファイル指定キャンセル時の処理        MsgBox "キャンセルされました"        End    Else        Set temp_book = Workbooks.Open(book_path) 'ファイルを開く    End If

   Sheets("Sheet1").Range("A1").CurrentRegion.Copy 'コピーして貼り付け    ThisWorkbook.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues    temp_book.Close

   ThisWorkbook.Sheets("Sheet1").Range("A1").Select 'セレクトを固定位置に

End Sub

流れとしては

カレントフォルダを現在のフォルダに移動

→移動させるファイルを選んでもらう（このときカレントフォルダを開くので、指定した）

→ファイルが指定されたら、コピー貼り付け

→フォルダを閉じる

→セレクトされているセルがコピーされたとこ全体になっているので、それを直す

という感じです。

ChDirでカレントフォルダの移動ができます。

また、ファイルの指定をさせるのは、Application.GetOpenFilenameでできます。

このとき、”Microsoft Excelブック,*.xls?”と指定することで、ファイルの種類と拡張子を絞ることができます。

ただ、意図していないファイルを開かれたときの処理はしていないので、そのときの処理を考える必要がありますね。

[kotaexcel]

Excelファイルをまとめて操作する

今回は、フォルダに入っているファイルをまとめて操作するマクロを作っていきます。

といっても、ほとんど参考書に書いてあったコードのままですが……

参考書：Excel VBAの教科書

流れとしては

フォルダの中にあるファイルのパスのリスト作成→一つずつ操作

という感じですが、前半のリスト作成の部分は関数にしていきます。

Function get_book_path_list(folder_path As String, _    Optional target_ex As String = "xlsx") As Variant 'folder_pathで指定したフォルダから 'target_exで指定した拡張子のファイルのパスのリストを得る    '    Dim dic As Object, temp_file As Object, temp_extension As String

   Set dic = CreateObject("Scripting.Dictionary")

   With CreateObject("Scripting.FileSystemObject")        For Each temp_file In .GetFolder(folder_path).Files            temp_extension = .GetExtensionName(temp_file)            If temp_extension = target_ex Then dic.Add temp_file.Path, "dummy"        Next    End With

   get_book_path_list = dic.keys

End Function

指定したフォルダの中に指定した拡張子のファイルのパスをリスト化する関数です。

拡張子は設定し��ければ xlsx。

フォルダの中にあるファイルを調べて、拡張子があっているものだけをDictionaryに集めています。

Dictionaryには、キー値にファイルのパスを保存していき、値はいらないのでdummyにしてあります。

最後にキー値のリストを受け取って終了です。

次に、このリストを使って、ファイル操作をまとめて行っていきます。

以前作った、売上管理表に実装していきます。

とりあえず実験的な感じなので、実際のファイルの操作自体は簡単なものにしています。

Sub sum_file_data() '過去データの集計をする

   Application.ScreenUpdating = False

   Dim book_path_list() As Variant, temp_path As Variant, _        temp_book As Workbook, total As Long

   book_path_list = get_book_path_list(ThisWorkbook.Path & "\保存フォルダ")

   For Each temp_path In book_path_list

       Set temp_book = Workbooks.Open(temp_path)        total = total + temp_book.Sheets("Sheet1").Cells(3, 10).Value        temp_book.Close    Next

   ThisWorkbook.Sheets("合計").Cells(3, 10) = total

End Sub

さっきの関数でリストを作って、それぞれのファイルで

ファイルを開く→ファイル操作→ファイルを閉じる

を繰り返しています。

作ってみて思ったのは、あまりファイル数が多くなかったのに実行にかなり時間がかかったこと。

頻繁に使うようなマクロでは使いにくそうですね。

データの集計とかに使いたければ、本体のブックにデータを転記する作業は今回のようなマクロを使って、そこから集計などの細かい操作をするのはブック内で収めた方がよさそうですね。

[kotaexcel]

同名ファイルを保存するときの処理をパーツ化する

今回は、マクロ内で同名ファイルを保存するときに、

上書きorSaveキャンセルor名前の変更

を選択で��るようにMsgBoxで呼びかけるマクロを作っていきます。

ではまずはコードから。

Sub save_same_filename(file_fullname As String) 'MsgBoxを用いて、同名ファイルがあったときに、 '上書きorSaveキャンセルor名前の変更 'を選択し、場合によっては処理がループするようにする

   Dim flag As Boolean, file_name As String, folder_path As String, _        result As VbMsgBoxResult, fso As Object, i As Long, _        u_target As Long, file_extension As String

   Set fso = CreateObject("Scripting.FileSystemObject")

   file_name = fso.GetBaseName(file_fullname)    folder_path = fso.GetParentFolderName(file_fullname)    file_extension = fso.GetExtensionName(file_fullname)

   Do While Not flag        If fso.FileExists(file_fullname) Then '同名ファイルが存在したら            result = MsgBox( _                "同じファイル名のファイルがあります。上書きしますか？", _                Buttons:=vbYesNo)            If result = vbYes Then '上書きするなら終了                flag = True            Else '上書きしないなら                result = MsgBox( _                    "ファイル名を変更しますか？", _                    Buttons:=vbYesNo)                If result = vbYes Then 'ファイル名を変更するなら                    file_name = InputBox("ファイル名を入力してください", _                        , file_name)                    If file_name = "" Then End 'キャンセルか空白入力で終了                    file_fullname = folder_path & "\" & file_name & "." & file_extension                Else 'ファイル名を変更しないなら終了                    Exit Sub                End If            End If        Else '同名ファイルが存在しなかったら終了            flag = True        End If    Loop

End Sub

ポイントは前回紹介したScripring.FileSystemObjectを使う方法です。

あとは、このマクロを呼びだしたマクロも終了する「End」。

flagはループから逃げるために用意しましたが、End subとかExit Doでもよかったですね。

ということで、詳しい説明は省きますが、こんな感じです（投げやり）。

[kotaexcel]

ファイルのFullNameをファイルのパスとファイル名に分割する２

前回投稿したものより簡単な方法をお教えいただいたので、ご紹介します。（本人了承済み　@reime)

Sub file_name_test()    Dim target_file_fullname As String    target_file_fullname = "D:\test.xlsm"    Debug.Print "元のパス:" & target_file_fullname

   With CreateObject("Scripting.FileSystemObject")

       Debug.Print "フォルダのパス:" & .GetParentFolderName(target_file_fullname)        Debug.Print "ファイルのパス:" & .GetFileName(target_file_fullname)        Debug.Print "ファイル名のみ:" & .GetBaseName(target_file_fullname)        Debug.Print "拡張子:" & .GetExtensionName(target_file_fullname)

   End With

End Sub

Scripting.FileSystemObjectを用いる方法は、ファイルから名前などを取得するだけでなく、パスの文字列からも取得することができるようです。

ちなみに

New Scripting.FileSystemObject

とする方法もありますが、参照設定等が必要になるようです。

https://www.atmarkit.co.jp/ait/articles/1703/14/news022.html

ですので、上にのせたコードでは

CreateObjectでやる方法にしました。

ということで、次回はこれを使ってコードを書いていきます。

ｐｓ

今回で１００回目の投稿です。

今後は２日一回投稿にしたいと思います。

空いている日にはWeb制作の方を頑張ります。

[kotaexcel]

ファイルのFullNameをファイルのパスとファイル名に分割する

今回は、ファイルのFullName……つまり、ファイルのパスとファイル名がくっつ��ているものを、それぞれに分割するマクロを作ります。

まずはコードから。

Sub sample24()    Dim temp As Variant, i As Long, folder_path As String, file_name As String    temp = Split(ThisWorkbook.FullName, "\")

   file_name = temp(UBound(temp))

   folder_path = temp(0)

   For i = 1 To UBound(temp) - 1        folder_path = folder_path & "\" & temp(i)    Next End Sub

な￥仕組みは単純なもので、まずはSplitでFullNameを「\」で分割します。

Splitは分割して配列として渡してくれるので、それをtempに入れます。

tempの最後の要素がファイル名。それまでの要素を「\」でつなぎなおしたものがパスなので、あとはそれぞれうまい具合に取得するだけです。

まぁ今回のマクロだと、そもそもThisWorkbook.Nameとかでファイル名が取得できるのでうまみはありませんが、例えばファイルのFullNameを受け取って処理をするときなどに役に立ちます。

ということで、記念すべき１００回目の投稿では、これを使って、マクロを作っていきたいと思います。

[kotaexcel]

イベント処理でシートの変化を他のシートに反映させる

今回はイベント処理を使います。

まずはコードから。

Private Sub Worksheet_Change(ByVal Target As Range)    If Not Intersect(Target, Range("C1")) Is Nothing Then        Sheets("sample").Range("C1") = Range("C1")    End If End Sub

これを対象のワークシートモジュールに記述します。

今回は売上表の日付を変更すると、sample���シートコピーのもとになるシート）の日付が変更されるようになっています。

このように、こちらからマクロを実行しなくても、条件に合わせて実行するプロシージャをイベントプロシージャといいます。

イベントプロシージャは、マクロ名が決まっています。

今回の場合は、セルの内容が変化したらマクロが起動される「Worksheet_Change」です。

Targetには変更されたセルが格納されています。

ですので、目的のセルが変更したかどうかを確認するために、Intersectを使っています。これは共通部分があるときに、その共通するセルを返すものです。

ですので、これがNothingでない……つまり空でないときにマクロの中身が実行されるようにすればいいわけですね。

ちなみに、このようにシートにマクロを保存したので、これをコピーして保存しよとすると、「マクロ対応の形式で保存してください」と言われてしまいます。

ですので、シートをコピーするマクロでは、早めにDisplayAlertsをFalseにするようにして、ファイル形式がマクロなしのまま保存されるようにしました。

[kotaexcel]

Buttonなどの図形全般を扱うShapesコレクションを使ってボタンを消してシートをコピーする

売上表についてシートのコピーをしていまいしたが、マクロを実行するボタンを取っておいたままコピーしたくないため、ボタンを消すコードを追加しました。

まずはコピーする部分を少し変えて、ボタンがあるシートも選択してコピーするようにします。

   Set temp = Sheets("start")    temp.Select False

   For i = 1 To sh_count + 1        Set temp = temp.Next        temp.Select False    Next

------before------

-----after-------

そして、ボタンを消すコードを追加します。

こうすると、自動計算モードだとかなり処理に時間がかかってしまいますので、自動計算をオフにするコードも足しておきます。

もちろん、自動計算の設定をもとに戻しておくのも忘れずに。

今回はコピー元とコピー先の２つのブックがあるので、どちらも戻しておきます。

これで集計結果も保存された状態でコピーができました。

[kotaexcel]

ファイル名がかぶっていたら名前の変更をできるようにする

今回はファイル名が被ったときに名前の入力が��きるようにしました。

ちょっと動画をここにのせるのがうまくいかなかったので、もしよろしければTwitterをどうぞ→https://twitter.com/Kotabrog

ということで、コードはかなり長くなっています。

   If fso.FileExists(file_fullname) Then        result = MsgBox( _            "同じ年月のバックアップファイルがあります。上書きしますか？", _            Buttons:=vbYesNo)        If result = vbYes Then            flag = True        Else            result = MsgBox( _                "ファイル名を変更して保存しますか？", _                Buttons:=vbYesNo)            If result = vbYes Then                file_name = InputBox("ファイル名を入力してください", _                    , file_name)                If file_name = "" Then Exit Sub                file_fullname = folder_path & "/" & file_name

               Do While Not flag2                    If fso.FileExists(file_fullname) Then                        result = MsgBox( _                            "同じファイル名のファイルがあります。上書きしますか？", _                            Buttons:=vbYesNo)                        If result = vbYes Then                            flag = True                            flag2 = True                        Else                            result = MsgBox( _                                "ファイル名を変更しますか？", _                                Buttons:=vbYesNo)                            If result = vbYes Then                                file_name = InputBox("ファイル名を入力してください", _                                    , file_name)                                If file_name = "" Then Exit Sub                                file_fullname = folder_path & "/" & file_name                            Else                                Exit Sub                            End If                        End If                    Else                        flag2 = True                    End If                Loop

           Else                Exit Sub            End If        End If    End If

途中から受け答えによってはループするようになっています。

まぁ動画を見れば何をしたかすぐわかると思うので、ぜひ。

あっ、ちなみにInputBoxを使っていて、もしキャンセルを押すと「””」が返ってくることなどを利用しています。

（段々説明すらしなくなってきた件について）

[kotaexcel]

ファイルをコピーした際に同名ファイルがあったときの処理

売上表にファイルのバックアップをとる機能がありましたが、このときすでにファイルがあると、「上書きしますか？」という問いかけがでてきます。

もしここで「No」を選ぶとマクロが止まって、VBEが開かれてしまい、マクロを使った人は「なんだこの画面は……」と困惑してしまうかもしれません。

それを防ぐために、あらかじめMsgBoxを出して、上書きするかどうか聞いておき、それに応じて処理を変えるようにします。

それではコードです。

   If fso.FileExists(file_fullname) Then        result = MsgBox( _            "同じ年月のバックアップファイルがあります。上書きしますか？", _            Buttons:=vbYesNo)        If result = vbYes Then            flag = True        Else            Exit Sub        End If    End If

まずはファイルが存在するかどうかを確かめ、存在したらMsgBoxを出します。

そこでNoであればマクロを終了し、Yesであれば、コピーをする前にアラートがでないようにしておきます。

[kotaexcel]

FileSystemObjectを使って、フォルダがあるかの確認とフォルダ作成

例えばフォルダになんらかのファイルを保存するマクロを作るとして、そのフォルダがないからといってマクロが止まってしまっては不便です。

そこで、今回はフォルダがあるかを調べ、なければ追加するコードを、売上表のマクロに追加していきます。

さっそくコードです。

   Set fso = CreateObject("Scripting.FileSystemObject")

   If Not fso.FolderExists(folder_path) Then        fso.CreateFolder (folder_path)    End If

まず最初に、外部ライブラリを使用するために、FileSystemObjectを生成します。

そしてそれを使って、FolderExistsでフォルダがあるかを確認し、なければ作成するようにしています。

ということで、これでフォルダがなくてもしっかりマクロが動くようになりました。

[kotaexcel]

マクロの処理速度を早くする！　計算ストップと実行速度の計測

前回売上表に関数をいれたところ、マクロ実行がとても遅くなってしまいました。

原因は簡単で、マクロ実行中にも都度シート上で大量の計算が行なわれるからです。

そこで今回は、マクロ実行中の計算をストップさせて、それでどれだけマクロが早くなったのかを見ていきます。

まずは、実行速度を計測するコードを書いていきます。

tmp_time = Timer Debug.Print Timer - tmp_time

まずtmp_timeに現在の時間（実行前の時間）を入れていて、最後に現在の時間（実行後の時間）からtmp_timeを引きます。こうすることで、どれだけ時間がかかったかを計ることができます。

次に、シートの計算をストップするコードを入れていきます。

   cal_mode = Application.Calculation    Application.Calculation = xlCalculationManual

   Application.Calculation = cal_mode

cal_modeに現在の計算モードを保存します。

現在の計算モードはApplication.Caluclationに保存されています。

そして、次に現在の計算モードを自動計算オフ（xlCalclationManual）にします。

最後にもとの計算モードに戻して終わりです。

それでは実際にマクロを実行してみます。

上が改良前、下が改良後です。

なんと１０秒も早くなりました！

これでだいぶマクロが軽くなりました。

ついでにもうひとつのシートを削除するマクロも改良します。

1.6→0.4で大幅に早くなりました。

シートに関数を用いている場合は、計算をストップさせるとかなり早くなるので、おすすめですね。

[kotaexcel]

IFERROR,OFFSET,MATCHを使って、商品の金額を参照する

今回は、商品名を入力すると金額が表示されるようにします。

前回に引き続き、売上表ですが、改良前はこんな感じ。

これが

このようになります。

商品を入力すると、単価を参照するように各シートを調整します。

各シートの改良前はこんな感じ。

そして

「売上」の列に以下の関数を入力します。

=IFERROR(OFFSET(Sheet1!$F$4, MATCH(I4, Sheet1!H:H, 0)-4, 0)*J4,"")

IFERROR関数はエラー値のときの表示を指定できます。

今回は「””」、つまり何も入力されていない状態を表示するようにしています。

だいたい１００列くらいこの関数を入力しているので、商品と個数を入力すれば自動で金額が算出されます。また入力されていなくても、何も表示されません。

OFFSET（基準セル、ずらす行数、ずらす列数）です。

MATCH（検索値、参照範囲、照合の型）で、商品名が上から何番目の商品名かを返しています。

これでOFFSETに入れる「ずらす行数」を取得して、単価を求めているわけです。

[kotaexcel]

入力規則でリスト作成

今回もマクロなしです。

データーの入力規則を用いて、変化する参照範囲に対応したリストを作っていきます。

このようにドロップダウンリストを作りたい個所を選択して、データの入力規則を設定していきます。

=OFFSET(Sheet1!$E$5,0,0,COUNTA(Sheet1!$E:$E)-1,1)

OFFSET（基準セル、ずらす行数、ずらす列数、高さ、幅）

であり、COUNTAで高さを調整して、商品が増えたり減ったりしてもリストの高さがちょうどよくなるようにしています。

ちなみに

COUNT→数値が入力されているセルを数える

COUNTA→空白でないセルを数える

というようになっていて、文字列を数えるときはCOUNTAを使用します。

リストが不要な部分も選択してあったので、その部分は入力規則をクリアにしておきます。

このように入力が簡単になりました。

[kotaexcel]

商品ごとの合計を求める

今回はマクロは使いません。

Excelの関数を使って商品ごとの合計を求めていきます。

こんな感じで、日付ごとのシートに保存されている商品の売買記録をもとに月の商品ごとの合計を求めていきます。

SUMIF関数で求めます。

Sheet1の一番上の商品に一致するものだけ合計していきます。

このセルの右下の四角くなっているところをつかんで、下にドラックしてコピーします。

すると、参照している商品も下にずれて、各商品の合計が求まります。

今度は、この金額をシートを串刺しにするように合計していくのですが……それは曜日のときにやりました。

ですので、今回は同じようにコピーしていくだけです。

これで商品ごとの合計が求まりました。

[kotaexcel]

ファイル名やシート名に日付を入れる

今回は、前回までで作った「シートを作るマクロ」と「シートをコピーするマクロ」で、「２０１９０９０２」のように固定された文字数で日付を入れられようにします。

まずは日付ごとのシートを作るマクロから。

ActiveSheet.Name = .Range("A1") & Format(.Range("C1"), "00") & Format(i, "00")

例えばFormat（1,  “00″）= 01 となります。

このマクロを実行すると以下のようになります。

次に、シートをコピーするマクロです。

＊コードは変更点だけです。

   file_name = Range("A1") & Format(Range("C1"), "00") & "売上データ.xlsx"

   ActiveWorkbook.SaveAs Filename:=folder_path & "/" & file_name

これでこのマクロがあるフォルダにある「保存フォルダ」に、「201908売上データ.xlsx」のように保存されます。

このように表記を一定にすれば、あとでマクロでブックの参照を行う時に扱いやすくなります。

[kotaexcel]

シートのコピーのバックアップをとる

前回はワークブックそのままのバックアップをとっていましたが、今回はシートのみの（つまりマクロとかは保存しない）バックアップをとるマクロをざっくりと作っていきます。

さっそくコードから。

Sub copy_sheets()

   Application.ScreenUpdating = False

   Dim temp As Variant, i As Long, folder_path As String, _    sh_count As Long

   folder_path = ThisWorkbook.Path & "/保存フォルダ"

   sh_count = Sheets.Count - 4    If sh_count = 0 Then        Exit Sub    End If

   Set temp = Sheets("start").Next    temp.Select

   For i = 1 To sh_count - 1        Set temp = temp.Next        temp.Select False    Next

   ActiveWindow.SelectedSheets.Copy

   ActiveWorkbook.SaveAs Filename:=folder_path & "/売上データ.xlsx"

   Application.DisplayAlerts = False    ActiveWorkbook.Close    Application.DisplayAlerts = True

   Sheets("Sheet1").Select

End Sub

流れとしては

シートをグループとしてセレクト

→コピーして保存

→コピーしたものを閉じる

という感じです。

グループとしてセレクトするには、

シート.Select False

というようにします。こうすることで、セレクト状態を解除せずに次のシートもセレクトすることができます。

そしてこれらのシートはActiveWindow.SelectedSheetsで扱えます。

たしか配列形式で保存されていたかと思いますが、コピーうまくいくんですね（うまくいかないかなと思いながら実行したらうまくいったパターン）。

このままマクロを終了すると複数シートが選択されている状態になっているので、最後にSheet1を選択しています。

ちなみに、今回はシートだけを保存していて、マクロは引き継がれていないので、ファイルの形式は.xlsx(マクロが保存できない形式)にしておきます。

このマクロをワークシートにボタンとして張り付けておきます。

これでシートの自動作成、自動削除、自動コピーが実装できました。

次回から細かな調整をしていく予定です。

[kotaexcel]

ファイルをコピーしてバックアップをとる

今回はファイルをコピーしてバックアップをとるマクロを作成していきます。

今回作ったものはまだ使いづらい状態です。

ではさっそくコードを。

Sub save_sheets()    Application.ScreenUpdating = False

   Dim folder_path As String, temp As Variant, file_fullname As String

   ThisWorkbook.Save    file_fullname = ThisWorkbook.FullName

   folder_path = ThisWorkbook.Path & "/保存フォルダ"

   ThisWorkbook.SaveAs Filename:=folder_path & "/売上データ.xlsm"

   Set temp = ThisWorkbook

   Workbooks.Open file_fullname

   temp.Close

End Sub

流れとしては、

ファイルを保存してファイル名を所得（パスも含めて）

→”保存フォルダ”に”売上データ”として保存

→”売上データ”ファイルをtempに保存

→もともとのファイルを開く

→”売上データ”を閉じる

という感じです。

コピーすると今見ているファイルがコピー先のファイルとして認識されてしまうので、このように、もともとのファイルを開きなおしています。

まぁまだ使いづらい状態なので、改良していきます。